{- |
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 :: 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 = [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
loop []
 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. 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. 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
_ 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)