    -- |
    -- 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 :: BER -> ByteString -> Either ASN1Error [ASN1Repr]
    decodeASN1Repr BER
    _ ByteString
    lbs = (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr (Maybe ASN1Error -> ASN1Header -> Maybe ASN1Error
    forall a b. a -> b -> a
    const Maybe ASN1Error
    forall a. Maybe a
    Nothing) ([ASN1Event] -> [ASN1Repr])
    -> Either ASN1Error [ASN1Event] -> Either ASN1Error [ASN1Repr]
    forall a b. (a -> b) -> Either ASN1Error a -> Either ASN1Error b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` ByteString -> Either ASN1Error [ASN1Event]
    parseLBS ByteString
    lbs

    instance ASN1Decoding BER where
        decodeASN1 :: BER -> ByteString -> Either ASN1Error [ASN1]
    decodeASN1 BER
    _ ByteString
    lbs = ((ASN1Repr -> ASN1) -> [ASN1Repr] -> [ASN1]
    forall a b. (a -> b) -> [a] -> [b]
    map ASN1Repr -> ASN1
    forall a b. (a, b) -> a
    fst ([ASN1Repr] -> [ASN1])
    -> ([ASN1Event] -> [ASN1Repr]) -> [ASN1Event] -> [ASN1]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr (Maybe ASN1Error -> ASN1Header -> Maybe ASN1Error
    forall a b. a -> b -> a
    const Maybe ASN1Error
    forall a. Maybe a
    Nothing)) ([ASN1Event] -> [ASN1])
    -> Either ASN1Error [ASN1Event] -> Either ASN1Error [ASN1]
    forall a b. (a -> b) -> Either ASN1Error a -> Either ASN1Error b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` ByteString -> Either ASN1Error [ASN1Event]
    parseLBS ByteString
    lbs

    instance ASN1DecodingRepr DER where
        decodeASN1Repr :: DER -> ByteString -> Either ASN1Error [ASN1Repr]
    decodeASN1Repr DER
    _ ByteString
    lbs = (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr ASN1Header -> Maybe ASN1Error
    checkDER ([ASN1Event] -> [ASN1Repr])
    -> Either ASN1Error [ASN1Event] -> Either ASN1Error [ASN1Repr]
    forall a b. (a -> b) -> Either ASN1Error a -> Either ASN1Error b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` ByteString -> Either ASN1Error [ASN1Event]
    parseLBS ByteString
    lbs

    instance ASN1Decoding DER where
        decodeASN1 :: DER -> ByteString -> Either ASN1Error [ASN1]
    decodeASN1 DER
    _ ByteString
    lbs = ((ASN1Repr -> ASN1) -> [ASN1Repr] -> [ASN1]
    forall a b. (a -> b) -> [a] -> [b]
    map ASN1Repr -> ASN1
    forall a b. (a, b) -> a
    fst ([ASN1Repr] -> [ASN1])
    -> ([ASN1Event] -> [ASN1Repr]) -> [ASN1Event] -> [ASN1]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr ASN1Header -> Maybe ASN1Error
    checkDER) ([ASN1Event] -> [ASN1])
    -> Either ASN1Error [ASN1Event] -> Either ASN1Error [ASN1]
    forall a b. (a -> b) -> Either ASN1Error a -> Either ASN1Error b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` ByteString -> Either ASN1Error [ASN1Event]
    parseLBS ByteString
    lbs

    instance ASN1Encoding DER where
        encodeASN1 :: DER -> [ASN1] -> ByteString
    encodeASN1 DER
    _ [ASN1]
    l = [ASN1Event] -> ByteString
    toLazyByteString ([ASN1Event] -> ByteString) -> [ASN1Event] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ [ASN1] -> [ASN1Event]
    encodeToRaw [ASN1]
    l

    decodeConstruction :: ASN1Header -> ASN1ConstructionType
    decodeConstruction :: ASN1Header -> ASN1ConstructionType
    decodeConstruction (ASN1Header ASN1Class
    Universal Int
    0x10 Bool
    _ ASN1Length
    _) = ASN1ConstructionType
    Sequence
    decodeConstruction (ASN1Header ASN1Class
    Universal Int
    0x11 Bool
    _ ASN1Length
    _) = ASN1ConstructionType
    Set
    decodeConstruction (ASN1Header ASN1Class
    c Int
    t Bool
    _ ASN1Length
    _)            = ASN1Class -> Int -> ASN1ConstructionType
    Container ASN1Class
    c Int
    t

    decodeEventASN1Repr :: (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr :: (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
    decodeEventASN1Repr ASN1Header -> Maybe ASN1Error
    checkHeader [ASN1Event]
    l = [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
    loop [] [ASN1Event]
    l
        where loop :: [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
    loop [ASN1ConstructionType]
    _ []     = []
              loop [ASN1ConstructionType]
    acc (h :: ASN1Event
    h@(Header hdr :: ASN1Header
    hdr@(ASN1Header ASN1Class
    _ Int
    _ Bool
    True ASN1Length
    _)):ASN1Event
    ConstructionBegin:[ASN1Event]
    xs) =
                    let ctype :: ASN1ConstructionType
    ctype = ASN1Header -> ASN1ConstructionType
    decodeConstruction ASN1Header
    hdr in
                    case ASN1Header -> Maybe ASN1Error
    checkHeader ASN1Header
    hdr of
                        Maybe ASN1Error
    Nothing  -> (ASN1ConstructionType -> ASN1
    Start ASN1ConstructionType
    ctype,[ASN1Event
    h,ASN1Event
    ConstructionBegin]) ASN1Repr -> [ASN1Repr] -> [ASN1Repr]
    forall a. a -> [a] -> [a]
    : [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
    loop (ASN1ConstructionType
    ctypeASN1ConstructionType
    -> [ASN1ConstructionType] -> [ASN1ConstructionType]
    forall a. a -> [a] -> [a]
    :[ASN1ConstructionType]
    acc) [ASN1Event]
    xs
                        Just ASN1Error
    err -> ASN1Error -> [ASN1Repr]
    forall a e. (HasCallStack, Exception e) => e -> a
    E.throw ASN1Error
    err
              loop [ASN1ConstructionType]
    acc (h :: ASN1Event
    h@(Header hdr :: ASN1Header
    hdr@(ASN1Header ASN1Class
    _ Int
    _ Bool
    False ASN1Length
    _)):p :: ASN1Event
    p@(Primitive ByteString
    prim):[ASN1Event]
    xs) =
                    case ASN1Header -> Maybe ASN1Error
    checkHeader ASN1Header
    hdr of
                        Maybe ASN1Error
    Nothing -> case ASN1Header -> ByteString -> ASN1Ret
    decodePrimitive ASN1Header
    hdr ByteString
    prim of
                            Left ASN1Error
    err  -> ASN1Error -> [ASN1Repr]
    forall a e. (HasCallStack, Exception e) => e -> a
    E.throw ASN1Error
    err
                            Right ASN1
    obj -> (ASN1
    obj, [ASN1Event
    h,ASN1Event
    p]) ASN1Repr -> [ASN1Repr] -> [ASN1Repr]
    forall a. a -> [a] -> [a]
    : [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
    loop [ASN1ConstructionType]
    acc [ASN1Event]
    xs
                        Just ASN1Error
    err -> ASN1Error -> [ASN1Repr]
    forall a e. (HasCallStack, Exception e) => e -> a
    E.throw ASN1Error
    err
              loop (ASN1ConstructionType
    ctype:[ASN1ConstructionType]
    acc) (ASN1Event
    ConstructionEnd:[ASN1Event]
    xs) = (ASN1ConstructionType -> ASN1
    End ASN1ConstructionType
    ctype, [ASN1Event
    ConstructionEnd]) ASN1Repr -> [ASN1Repr] -> [ASN1Repr]
    forall a. a -> [a] -> [a]
    : [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
    loop [ASN1ConstructionType]
    acc [ASN1Event]
    xs
              loop [ASN1ConstructionType]
    _ (ASN1Event
    x:[ASN1Event]
    _) = ASN1Error -> [ASN1Repr]
    forall a e. (HasCallStack, Exception e) => e -> a
    E.throw (ASN1Error -> [ASN1Repr]) -> ASN1Error -> [ASN1Repr]
    forall a b. (a -> b) -> a -> b
    $ String -> ASN1Error
    StreamUnexpectedSituation (ASN1Event -> String
    forall a. Show a => a -> String
    show ASN1Event
    x)

    -- | DER header need to be all of finite size and of minimum possible size.
    checkDER :: ASN1Header -> Maybe ASN1Error
    checkDER :: ASN1Header -> Maybe ASN1Error
    checkDER (ASN1Header ASN1Class
    _ Int
    _ Bool
    _ ASN1Length
    len) = ASN1Length -> Maybe ASN1Error
    checkLength ASN1Length
    len
        where checkLength :: ASN1Length -> Maybe ASN1Error
              checkLength :: ASN1Length -> Maybe ASN1Error
    checkLength ASN1Length
    LenIndefinite = ASN1Error -> Maybe ASN1Error
    forall a. a -> Maybe a
    Just (ASN1Error -> Maybe ASN1Error) -> ASN1Error -> Maybe ASN1Error
    forall a b. (a -> b) -> a -> b
    $ String -> String -> ASN1Error
    PolicyFailed String
    "DER" String
    "indefinite length not allowed"
              checkLength (LenShort Int
    _)  = Maybe ASN1Error
    forall a. Maybe a
    Nothing
              checkLength (LenLong Int
    n Int
    i)
                  | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1 Bool -> Bool -> Bool
    && Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0x80  = ASN1Error -> Maybe ASN1Error
    forall a. a -> Maybe a
    Just (ASN1Error -> Maybe ASN1Error) -> ASN1Error -> Maybe ASN1Error
    forall a b. (a -> b) -> a -> b
    $ String -> String -> ASN1Error
    PolicyFailed String
    "DER" String
    "long length should be a short length"
                  | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1 Bool -> Bool -> Bool
    && Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    0x80 = Maybe ASN1Error
    forall a. Maybe a
    Nothing
                  | Bool
    otherwise           = if Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    2Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^((Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)Int -> Int -> Int
    forall a. Num a => a -> a -> a
    *Int
    8) Bool -> Bool -> Bool
    && Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    2Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    *Int
    8)
                      then Maybe ASN1Error
    forall a. Maybe a
    Nothing
                      else ASN1Error -> Maybe ASN1Error
    forall a. a -> Maybe a
    Just (ASN1Error -> Maybe ASN1Error) -> ASN1Error -> Maybe ASN1Error
    forall a b. (a -> b) -> a -> b
    $ String -> String -> ASN1Error
    PolicyFailed String
    "DER" String
    "long length is not shortest"

    encodeToRaw :: [ASN1] -> [ASN1Event]
    encodeToRaw :: [ASN1] -> [ASN1Event]
    encodeToRaw = ((ASN1, [ASN1]) -> [ASN1Event]) -> [(ASN1, [ASN1])] -> [ASN1Event]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (ASN1, [ASN1]) -> [ASN1Event]
    writeTree ([(ASN1, [ASN1])] -> [ASN1Event])
    -> ([ASN1] -> [(ASN1, [ASN1])]) -> [ASN1] -> [ASN1Event]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [ASN1] -> [(ASN1, [ASN1])]
    mkTree
        where writeTree :: (ASN1, [ASN1]) -> [ASN1Event]
    writeTree (p :: ASN1
    p@(Start ASN1ConstructionType
    _),[ASN1]
    children) = (Int, [ASN1Event]) -> [ASN1Event]
    forall a b. (a, b) -> b
    snd ((Int, [ASN1Event]) -> [ASN1Event])
    -> (Int, [ASN1Event]) -> [ASN1Event]
    forall a b. (a -> b) -> a -> b
    $ ASN1 -> [ASN1] -> (Int, [ASN1Event])
    encodeConstructed ASN1
    p [ASN1]
    children
              writeTree (ASN1
    p,[ASN1]
    _)                  = (Int, [ASN1Event]) -> [ASN1Event]
    forall a b. (a, b) -> b
    snd ((Int, [ASN1Event]) -> [ASN1Event])
    -> (Int, [ASN1Event]) -> [ASN1Event]
    forall a b. (a -> b) -> a -> b
    $ ASN1 -> (Int, [ASN1Event])
    encodePrimitive ASN1
    p

              mkTree :: [ASN1] -> [(ASN1, [ASN1])]
    mkTree []           = []
              mkTree (x :: ASN1
    x@(Start ASN1ConstructionType
    _):[ASN1]
    xs) =
                  let ([ASN1]
    tree, [ASN1]
    r) = Int -> [ASN1] -> ([ASN1], [ASN1])
    spanEnd Int
    0 [ASN1]
    xs
                   in (ASN1
    x,[ASN1]
    tree)(ASN1, [ASN1]) -> [(ASN1, [ASN1])] -> [(ASN1, [ASN1])]
    forall a. a -> [a] -> [a]
    :[ASN1] -> [(ASN1, [ASN1])]
    mkTree [ASN1]
    r
              mkTree (ASN1
    p:[ASN1]
    xs)       = (ASN1
    p,[]) (ASN1, [ASN1]) -> [(ASN1, [ASN1])] -> [(ASN1, [ASN1])]
    forall a. a -> [a] -> [a]
    : [ASN1] -> [(ASN1, [ASN1])]
    mkTree [ASN1]
    xs

              spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1])
              spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1])
    spanEnd Int
    _ []             = ([], [])
              spanEnd Int
    0 (x :: ASN1
    x@(End ASN1ConstructionType
    _):[ASN1]
    xs) = ([ASN1
    x], [ASN1]
    xs)
              spanEnd Int
    lvl (ASN1
    x:[ASN1]
    xs)       = case ASN1
    x of
                        Start ASN1ConstructionType
    _ -> let ([ASN1]
    ys, [ASN1]
    zs) = Int -> [ASN1] -> ([ASN1], [ASN1])
    spanEnd (Int
    lvlInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) [ASN1]
    xs in (ASN1
    xASN1 -> [ASN1] -> [ASN1]
    forall a. a -> [a] -> [a]
    :[ASN1]
    ys, [ASN1]
    zs)
                        End ASN1ConstructionType
    _   -> let ([ASN1]
    ys, [ASN1]
    zs) = Int -> [ASN1] -> ([ASN1], [ASN1])
    spanEnd (Int
    lvlInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) [ASN1]
    xs in (ASN1
    xASN1 -> [ASN1] -> [ASN1]
    forall a. a -> [a] -> [a]
    :[ASN1]
    ys, [ASN1]
    zs)
                        ASN1
    _       -> let ([ASN1]
    ys, [ASN1]
    zs) = Int -> [ASN1] -> ([ASN1], [ASN1])
    spanEnd Int
    lvl [ASN1]
    xs in (ASN1
    xASN1 -> [ASN1] -> [ASN1]
    forall a. a -> [a] -> [a]
    :[ASN1]
    ys, [ASN1]
    zs)