diff --git a/Data/ASN1/BinaryEncoding.hs b/Data/ASN1/BinaryEncoding.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding.hs @@ -0,0 +1,99 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Parse.hs @@ -0,0 +1,158 @@ +-- | +-- 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. +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 + [] -> Left StreamUnexpectedEOC + 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 _ -> error "primitive parsing failed" + 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Raw.hs @@ -0,0 +1,32 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Writer.hs @@ -0,0 +1,39 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Encoding.hs @@ -0,0 +1,51 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Error.hs @@ -0,0 +1,31 @@ +-- | +-- 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. + | 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Get.hs @@ -0,0 +1,197 @@ +-- | +-- 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 #-} +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 +import qualified Data.ByteString.Unsafe 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' + + 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 = do + s <- ensure n + put (fromIntegral n) $ B.unsafeDrop n s + return $ B.unsafeTake n s + +getWord8 :: Get Word8 +getWord8 = do + s <- ensure 1 + put 1 $ B.unsafeTail s + return $ B.unsafeHead s diff --git a/Data/ASN1/Internal.hs b/Data/ASN1/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Internal.hs @@ -0,0 +1,70 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Object.hs @@ -0,0 +1,12 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Prim.hs @@ -0,0 +1,355 @@ +-- | +-- Module : Data.ASN1.Prim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Tools to read ASN1 primitive (e.g. boolean, int) +-- + +{-# 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 + , getBitString + , getOctetString + , getNull + , getOID + , getTime + + -- * marshall an ASN1 type to a bytestring + , putTime + , putInteger + , 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.Word +import Data.List (unfoldr) +import Data.ByteString (ByteString) +import Data.Char (ord) +import qualified Data.ByteString as B +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.LocalTime +import Control.Arrow (first) + +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 _) = B.empty -- not implemented +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 in + let blen = B.length b in + let len = makeLength blen in + let 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 in + let (llen, lev) = encodeList zs in + let (len, ev) = encodeConstructed t ys in + (llen + len, ev ++ lev) + +encodeList (x:xs) = + let (llen, lev) = encodeList xs in + let (len, ev) = encodeOne x in + (llen + len, ev ++ lev) + +encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event]) +encodeConstructed c@(Start _) children = + let (clen, events) = encodeList children in + let len = mkSmallestLength clen in + let h = encodeHeader True len c in + let tlen = B.length (putHeader h) + clen in + (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) + +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 _ _) _ = Left $ TypeNotImplemented "real" +decodePrimitive (ASN1Header Universal 0xa _ _) _ = Left $ TypeNotImplemented "enumerated" +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 _ _) _ = error "sequence not a primitive" +decodePrimitive (ASN1Header Universal 0x11 _ _) _ = error "set not a primitive" +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 +getInteger s + | B.length s == 0 = Left $ TypeDecodingFailed "integer: null encoding" + | B.length s == 1 = Right $ IntVal $ snd $ intOfBytes s + | otherwise = + if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7)) + then Left $ TypeDecodingFailed "integer: not shortest encoding" + else Right $ IntVal $ snd $ intOfBytes s + where + v1 = s `B.index` 0 + v2 = s `B.index` 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 (B.unpack -> b) = Right $ ASN1Time timeType (UTCTime cDay cDiffTime) tz + where + cDay = fromGregorian year (fromIntegral month) (fromIntegral day) + cDiffTime = secondsToDiffTime (hour * 3600 + minute * 60 + sec) + + picosecondsToDiffTime msec --picosecondsToDiffTime (msec * ) + (year, b2) = case timeType of + TimeUTC -> first ((1900 +) . centurize . toInt) $ splitAt 2 b + TimeGeneralized -> first toInt $ splitAt 4 b + (month, b3) = first toInt $ splitAt 2 b2 + (day, b4) = first toInt $ splitAt 2 b3 + (hour, b5) = first toInt $ splitAt 2 b4 + (minute, b6) = first toInt $ splitAt 2 b5 + (sec, b7) = first toInt $ splitAt 2 b6 + (msec, b8) = case b7 of -- parse .[0-9] + 0x2e:b7' -> first toPico $ spanToLength 3 (\c -> fromIntegral c >= ord '0' && fromIntegral c <= ord '9') b7' + _ -> (0,b7) + (tz, _) = case b8 of + 0x5a:b8' -> (Just utc, b8') -- zulu + 0x2b:b8' -> (Just undefined, b8') -- + + 0x2d:b8' -> (Just undefined, b8') -- - + _ -> (Nothing, b8) + + spanToLength :: Int -> (Word8 -> Bool) -> [Word8] -> ([Word8], [Word8]) + 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) + + toPico :: [Word8] -> Integer + toPico l = toInt l * order * 1000000000 + where len = length l + order = case len of + 1 -> 100 + 2 -> 10 + 3 -> 1 + _ -> 1 + + toInt :: [Word8] -> Integer + toInt = foldl (\acc w -> acc * 10 + fromIntegral (fromIntegral w - ord '0')) 0 + + centurize v + | v <= 50 = v + 100 + | otherwise = v + +putTime :: ASN1TimeType -> UTCTime -> Maybe TimeZone -> ByteString +putTime ty (UTCTime day diff) mtz = B.pack etime + where + etime + | ty == TimeUTC = [y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2]++tzStr + | otherwise = [y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2]++msecStr++tzStr + + charZ = 90 + + msecStr = [] + tzStr = case mtz of + Nothing -> [] + Just tz | timeZoneMinutes tz == 0 -> [charZ] + | otherwise -> asciiToWord8 $ timeZoneOffsetString tz + + (y_,m,d) = toGregorian day + y = fromIntegral y_ + + secs = truncate (realToFrac diff :: Double) :: Integer + + (h,mins) = secs `divMod` 3600 + (mi,s) = mins `divMod` 60 + + split2 n = (fromIntegral $ n `div` 10 + ord '0', fromIntegral $ n `mod` 10 + ord '0') + ((y1,y2),(y3,y4)) = (split2 (y `div` 100), split2 (y `mod` 100)) + (m1, m2) = split2 m + (d1, d2) = split2 d + (h1, h2) = split2 $ fromIntegral h + (mi1, mi2) = split2 $ fromIntegral mi + (s1, s2) = split2 $ fromIntegral s + + asciiToWord8 :: [Char] -> [Word8] + asciiToWord8 = map (fromIntegral . fromEnum) + +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 = B.cons eoidclass subeoids + where + (oid1:oid2:suboids) = oids + eoidclass = fromIntegral (oid1 * 40 + oid2) + encode x | x == 0 = B.singleton 0 + | otherwise = putVarEncodingIntegral x + subeoids = B.concat $ map encode suboids diff --git a/Data/ASN1/Serialize.hs b/Data/ASN1/Serialize.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Serialize.hs @@ -0,0 +1,96 @@ +-- | +-- 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) $ error "not canonical encoding of 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 new file mode 100644 --- /dev/null +++ b/Data/ASN1/Stream.hs @@ -0,0 +1,41 @@ +-- | +-- 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2013 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,214 @@ +import Test.QuickCheck +import Test.Framework(defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2(testProperty) + +import Text.Printf + +import Control.Applicative +import Data.ASN1.Get (runGet, Result(..)) +import Data.ASN1.BitArray +import Data.ASN1.Stream +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.ASN1.OID + +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.LocalTime + +import Data.Word + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text.Lazy as T + +import Control.Monad +import Control.Monad.Identity +import System.IO + +instance Arbitrary ASN1Class where + 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 + +arbitraryDefiniteLength :: Gen ASN1Length +arbitraryDefiniteLength = arbitrary `suchThat` (\l -> l /= LenIndefinite) + +arbitraryTag :: Gen ASN1Tag +arbitraryTag = choose(1,10000) + +instance Arbitrary ASN1Header where + 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]) + +newtype ASN1Events = ASN1Events [ASN1Event] + +instance Show ASN1Events where + show (ASN1Events x) = show x + +instance Arbitrary ASN1Events where + 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) + +arbitraryBSsized :: Int -> Gen B.ByteString +arbitraryBSsized len = do + ws <- replicateM len (choose (0, 255) :: Gen Int) + return $ B.pack $ map fromIntegral ws + +instance Arbitrary B.ByteString where + arbitrary = do + len <- choose (0, 529) :: Gen Int + arbitraryBSsized len + +instance Arbitrary T.Text where + arbitrary = do + len <- choose (0, 529) :: Gen Int + ws <- replicateM len arbitrary + return $ T.pack ws + +instance Arbitrary BitArray where + arbitrary = do + bs <- arbitrary + --w <- choose (0,7) :: Gen Int + return $ toBitArray bs 0 + +instance Arbitrary Day where + arbitrary = do + y <- choose (1951, 2050) + m <- choose (0, 11) + d <- choose (0, 31) + return $ fromGregorian y m d + +instance Arbitrary DiffTime where + arbitrary = do + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) + return $ secondsToDiffTime (h*3600+mi*60+se) + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> arbitrary + +instance Arbitrary TimeZone where + arbitrary = return $ utc + +instance Arbitrary ASN1TimeType where + arbitrary = elements [TimeUTC, TimeGeneralized] + +instance Arbitrary ASN1StringEncoding where + arbitrary = elements [UTF8, Numeric, Printable, T61, VideoTex, IA5, Graphic, Visible, General, UTF32, BMP] + +arbitraryPrintString encoding = do + 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)) + +arbitraryIA5String = asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0,toEnum 127)) + +arbitraryUCS2 :: Gen ASN1CharacterString +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)) + +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 + ] + +instance Arbitrary ASN1 where + arbitrary = oneof + [ liftM Boolean arbitrary + , liftM IntVal arbitrary + , liftM BitString arbitrary + , liftM OctetString arbitrary + , return Null + , liftM OID arbitraryOID + --, Real Double + -- , return Enumerated + , ASN1String <$> arbitrary + , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary + ] + +newtype ASN1s = ASN1s [ASN1] + +instance Show ASN1s where + 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]) + +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_event_marshalling_id :: ASN1Events -> Bool +prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e + +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 + +marshallingTests = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Event" prop_event_marshalling_id + , testProperty "DER" prop_asn1_der_marshalling_id + ] + +main = defaultMain [marshallingTests] diff --git a/asn1-encoding.cabal b/asn1-encoding.cabal new file mode 100644 --- /dev/null +++ b/asn1-encoding.cabal @@ -0,0 +1,58 @@ +Name: asn1-encoding +Version: 0.8.0 +Description: + ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, and DER). +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +Synopsis: ASN1 data reader and writer in RAW, BER and DER forms +Build-Type: Simple +Category: Data +stability: experimental +Cabal-Version: >=1.6 +Homepage: http://github.com/vincenthz/hs-asn1 + +Flag test + Description: Build unit test + Default: False + +Library + Build-Depends: base >= 3 && < 5 + , bytestring + , text >= 0.11 + , mtl + , time + , asn1-types >= 0.2 && < 0.3 + + Exposed-modules: Data.ASN1.Error + Data.ASN1.BinaryEncoding + Data.ASN1.BinaryEncoding.Raw + Data.ASN1.Encoding + Data.ASN1.Stream + Data.ASN1.Object + other-modules: Data.ASN1.Prim + Data.ASN1.BinaryEncoding.Parse + Data.ASN1.BinaryEncoding.Writer + Data.ASN1.Internal + Data.ASN1.Serialize + Data.ASN1.Get + ghc-options: -Wall + +Executable Tests + Main-Is: Tests.hs + if flag(test) + Buildable: True + Build-depends: base >= 3 && < 7 + , HUnit + , QuickCheck >= 2 + , bytestring + , test-framework >= 0.3 + , test-framework-quickcheck2 >= 0.2 + else + Buildable: False + +source-repository head + type: git + location: git://github.com/vincenthz/hs-asn1