1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
-- |
-- 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)
|
