-- |
-- 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 (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 (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 (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 (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 ASN1Tag
0x10 Bool
_ ASN1Length
_) = ASN1ConstructionType
Sequence
decodeConstruction (ASN1Header ASN1Class
Universal ASN1Tag
0x11 Bool
_ ASN1Length
_) = ASN1ConstructionType
Set
decodeConstruction (ASN1Header ASN1Class
c ASN1Tag
t Bool
_ ASN1Length
_)            = ASN1Class -> ASN1Tag -> ASN1ConstructionType
Container ASN1Class
c ASN1Tag
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
_ ASN1Tag
_ 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. Exception e => e -> a
E.throw ASN1Error
err
          loop [ASN1ConstructionType]
acc (h :: ASN1Event
h@(Header hdr :: ASN1Header
hdr@(ASN1Header ASN1Class
_ ASN1Tag
_ 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. 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. 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. 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
_ ASN1Tag
_ 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 ASN1Tag
_)  = Maybe ASN1Error
forall a. Maybe a
Nothing
          checkLength (LenLong ASN1Tag
n ASN1Tag
i)
              | ASN1Tag
n ASN1Tag -> ASN1Tag -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1Tag
1 Bool -> Bool -> Bool
&& ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
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"
              | ASN1Tag
n ASN1Tag -> ASN1Tag -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1Tag
1 Bool -> Bool -> Bool
&& ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
>= ASN1Tag
0x80 = Maybe ASN1Error
forall a. Maybe a
Nothing
              | Bool
otherwise           = if ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
>= ASN1Tag
2ASN1Tag -> ASN1Tag -> ASN1Tag
forall a b. (Num a, Integral b) => a -> b -> a
^((ASN1Tag
nASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
-ASN1Tag
1)ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
*ASN1Tag
8) Bool -> Bool -> Bool
&& ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
2ASN1Tag -> ASN1Tag -> ASN1Tag
forall a b. (Num a, Integral b) => a -> b -> a
^(ASN1Tag
nASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
*ASN1Tag
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) = (ASN1Tag, [ASN1Event]) -> [ASN1Event]
forall a b. (a, b) -> b
snd ((ASN1Tag, [ASN1Event]) -> [ASN1Event])
-> (ASN1Tag, [ASN1Event]) -> [ASN1Event]
forall a b. (a -> b) -> a -> b
$ ASN1 -> [ASN1] -> (ASN1Tag, [ASN1Event])
encodeConstructed ASN1
p [ASN1]
children
          writeTree (ASN1
p,[ASN1]
_)                  = (ASN1Tag, [ASN1Event]) -> [ASN1Event]
forall a b. (a, b) -> b
snd ((ASN1Tag, [ASN1Event]) -> [ASN1Event])
-> (ASN1Tag, [ASN1Event]) -> [ASN1Event]
forall a b. (a -> b) -> a -> b
$ ASN1 -> (ASN1Tag, [ASN1Event])
encodePrimitive ASN1
p

          mkTree :: [ASN1] -> [(ASN1, [ASN1])]
mkTree []           = []
          mkTree (x :: ASN1
x@(Start ASN1ConstructionType
_):[ASN1]
xs) =
              let ([ASN1]
tree, [ASN1]
r) = ASN1Tag -> [ASN1] -> ([ASN1], [ASN1])
spanEnd ASN1Tag
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 :: ASN1Tag -> [ASN1] -> ([ASN1], [ASN1])
spanEnd ASN1Tag
_ []             = ([], [])
          spanEnd ASN1Tag
0 (x :: ASN1
x@(End ASN1ConstructionType
_):[ASN1]
xs) = ([ASN1
x], [ASN1]
xs)
          spanEnd ASN1Tag
lvl (ASN1
x:[ASN1]
xs)       = case ASN1
x of
                    Start ASN1ConstructionType
_ -> let ([ASN1]
ys, [ASN1]
zs) = ASN1Tag -> [ASN1] -> ([ASN1], [ASN1])
spanEnd (ASN1Tag
lvlASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
+ASN1Tag
1) [ASN1]
xs in (ASN1
xASN1 -> [ASN1] -> [ASN1]
forall a. a -> [a] -> [a]
:[ASN1]
ys, [ASN1]
zs)
                    End ASN1ConstructionType
_   -> let ([ASN1]
ys, [ASN1]
zs) = ASN1Tag -> [ASN1] -> ([ASN1], [ASN1])
spanEnd (ASN1Tag
lvlASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
-ASN1Tag
1) [ASN1]
xs in (ASN1
xASN1 -> [ASN1] -> [ASN1]
forall a. a -> [a] -> [a]
:[ASN1]
ys, [ASN1]
zs)
                    ASN1
_       -> let ([ASN1]
ys, [ASN1]
zs) = ASN1Tag -> [ASN1] -> ([ASN1], [ASN1])
spanEnd ASN1Tag
lvl [ASN1]
xs in (ASN1
xASN1 -> [ASN1] -> [ASN1]
forall a. a -> [a] -> [a]
:[ASN1]
ys, [ASN1]
zs)