packages feed

crypton-asn1-encoding 0.9.6 → 0.9.7

raw patch · 27 files changed

+1703/−1524 lines, 27 filesdep ~basedep ~crypton-asn1-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, crypton-asn1-types

API changes (from Hackage documentation)

- Data.ASN1.Stream: getConstructedEnd :: Int -> [ASN1] -> ([ASN1], [ASN1])
- Data.ASN1.Stream: getConstructedEndRepr :: [ASN1Repr] -> ([ASN1Repr], [ASN1Repr])
- Data.ASN1.Stream: type ASN1Repr = (ASN1, [ASN1Event])

Files

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