packages feed

asn1-encoding (empty) → 0.8.0

raw patch · 16 files changed

+1482/−0 lines, 16 filesdep +HUnitdep +QuickCheckdep +asn1-typessetup-changed

Dependencies added: HUnit, QuickCheck, asn1-types, base, bytestring, mtl, test-framework, test-framework-quickcheck2, text, time

Files

+ Data/ASN1/BinaryEncoding.hs view
@@ -0,0 +1,99 @@+-- |+-- Module      : Data.ASN1.BinaryEncoding+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Data/ASN1/BinaryEncoding/Parse.hs view
@@ -0,0 +1,158 @@+-- |+-- Module      : Data.ASN1.BinaryEncoding.Parse+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/BinaryEncoding/Raw.hs view
@@ -0,0 +1,32 @@+-- |+-- Module      : Data.ASN1.BinaryEncoding.Raw+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/BinaryEncoding/Writer.hs view
@@ -0,0 +1,39 @@+-- |+-- Module      : Data.ASN1.BinaryEncoding.Writer+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Encoding.hs view
@@ -0,0 +1,51 @@+-- |+-- Module      : Data.ASN1.Encoding+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Error.hs view
@@ -0,0 +1,31 @@+-- |+-- Module      : Data.ASN1.Error+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Get.hs view
@@ -0,0 +1,197 @@+-- |+-- Module      : Data.ASN1.Get+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Internal.hs view
@@ -0,0 +1,70 @@+-- |+-- Module      : Data.ASN1.Internal+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Object.hs view
@@ -0,0 +1,12 @@+-- |+-- Module      : Data.ASN1.Object+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+module Data.ASN1.Object {-# DEPRECATED "Use Data.ASN1.Types instead" #-}+    ( ASN1Object(..)+    ) where++import Data.ASN1.Types
+ Data/ASN1/Prim.hs view
@@ -0,0 +1,355 @@+-- |+-- Module      : Data.ASN1.Prim+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/ASN1/Serialize.hs view
@@ -0,0 +1,96 @@+-- |+-- Module      : Data.ASN1.Serialize+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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]
+ Data/ASN1/Stream.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      : Data.ASN1.Stream+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests.hs view
@@ -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]
+ asn1-encoding.cabal view
@@ -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 <vincent@snarc.org>+Author:              Vincent Hanquez <vincent@snarc.org>+Maintainer:          Vincent Hanquez <vincent@snarc.org>+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