{-# 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
data BER = BER
data DER = DER
instance ASN1DecodingRepr BER where
decodeASN1Repr :: BER -> ByteString -> Either ASN1Error [ASN1Repr]
decodeASN1Repr BER
_ ByteString
lbs = (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
decodeEventASN1Repr (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) 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 = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
decodeEventASN1Repr (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)) 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 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 = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]
decodeEventASN1Repr ASN1Header -> Maybe ASN1Error
checkDER) 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 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]) forall a. a -> [a] -> [a]
: [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
loop (ASN1ConstructionType
ctypeforall a. a -> [a] -> [a]
:[ASN1ConstructionType]
acc) [ASN1Event]
xs
Just ASN1Error
err -> 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 -> forall a e. Exception e => e -> a
E.throw ASN1Error
err
Right ASN1
obj -> (ASN1
obj, [ASN1Event
h,ASN1Event
p]) forall a. a -> [a] -> [a]
: [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
loop [ASN1ConstructionType]
acc [ASN1Event]
xs
Just ASN1Error
err -> 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]) forall a. a -> [a] -> [a]
: [ASN1ConstructionType] -> [ASN1Event] -> [ASN1Repr]
loop [ASN1ConstructionType]
acc [ASN1Event]
xs
loop [ASN1ConstructionType]
_ (ASN1Event
x:[ASN1Event]
_) = forall a e. Exception e => e -> a
E.throw forall a b. (a -> b) -> a -> b
$ String -> ASN1Error
StreamUnexpectedSituation (forall a. Show a => a -> String
show ASN1Event
x)
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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String -> ASN1Error
PolicyFailed String
"DER" String
"indefinite length not allowed"
checkLength (LenShort Int
_) = forall a. Maybe a
Nothing
checkLength (LenLong Int
n Int
i)
| Int
n forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< Int
0x80 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String -> ASN1Error
PolicyFailed String
"DER" String
"long length should be a short length"
| Int
n forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
>= Int
0x80 = forall a. Maybe a
Nothing
| Bool
otherwise = if Int
i forall a. Ord a => a -> a -> Bool
>= Int
2forall a b. (Num a, Integral b) => a -> b -> a
^((Int
nforall a. Num a => a -> a -> a
-Int
1)forall a. Num a => a -> a -> a
*Int
8) Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< Int
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
nforall a. Num a => a -> a -> a
*Int
8)
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ASN1, [ASN1]) -> [ASN1Event]
writeTree 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) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ ASN1 -> [ASN1] -> (Int, [ASN1Event])
encodeConstructed ASN1
p [ASN1]
children
writeTree (ASN1
p,[ASN1]
_) = forall a b. (a, b) -> b
snd 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)forall a. a -> [a] -> [a]
:[ASN1] -> [(ASN1, [ASN1])]
mkTree [ASN1]
r
mkTree (ASN1
p:[ASN1]
xs) = (ASN1
p,[]) 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
lvlforall a. Num a => a -> a -> a
+Int
1) [ASN1]
xs in (ASN1
xforall a. a -> [a] -> [a]
:[ASN1]
ys, [ASN1]
zs)
End ASN1ConstructionType
_ -> let ([ASN1]
ys, [ASN1]
zs) = Int -> [ASN1] -> ([ASN1], [ASN1])
spanEnd (Int
lvlforall a. Num a => a -> a -> a
-Int
1) [ASN1]
xs in (ASN1
xforall 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
xforall a. a -> [a] -> [a]
:[ASN1]
ys, [ASN1]
zs)