-- |
-- Module      : Crypto.Store.ASN1.Generate
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Generating ASN.1
module Crypto.Store.ASN1.Generate
    ( ASN1Stream
    , ASN1Elem()
    , ASN1P()
    , ASN1PS
    , asn1Container
    , gNull
    , gIntVal
    , gOID
    , gASN1String
    , gBMPString
    , gOctetString
    , gBitString
    , gASN1Time
    , gMany
    , gEncoded
    , optASN1S
    , encodeASN1S
    ) where

import           Data.ASN1.BinaryEncoding
import           Data.ASN1.BinaryEncoding.Raw
import           Data.ASN1.BitArray
import           Data.ASN1.Encoding
import           Data.ASN1.OID
import           Data.ASN1.Types
import qualified Data.ByteArray as B
import           Data.ByteString (ByteString)

import Time.Types (DateTime, TimezoneOffset)

-- | A stream of ASN.1 elements.
type ASN1Stream e = [e] -> [e]

-- | Elements in an ASN.1 stream.
class ASN1Elem e where
    -- | Create a container from an inner ASN.1 stream.
    asn1Container :: ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e
    -- | Generate a list of ASN.1 elements.
    gMany :: [ASN1] -> ASN1Stream e
    -- | Generate one ASN.1 element.
    gOne :: ASN1 -> ASN1Stream e

instance ASN1Elem ASN1 where
    asn1Container :: ASN1ConstructionType -> ASN1Stream ASN1 -> ASN1Stream ASN1
asn1Container ASN1ConstructionType
ty ASN1Stream ASN1
f = (ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
ty forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Stream ASN1
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASN1ConstructionType -> ASN1
End ASN1ConstructionType
ty forall a. a -> [a] -> [a]
:)
    gMany :: [ASN1] -> ASN1Stream ASN1
gMany = forall a. [a] -> [a] -> [a]
(++)
    gOne :: ASN1 -> ASN1Stream ASN1
gOne = (:)

-- | Extend the 'ASN1' type to be able to encode to ASN.1 even when some parts
-- of the stream have already been encoded.
data ASN1P
    = ASN1Prim [ASN1]
      -- ^ Primitive elements (or constructed types that are fully terminated)
    | ASN1Container !ASN1ConstructionType [ASN1P]
      -- ^ Constructed type with inner structure kept
    | ASN1Encoded !ByteString
      -- ^ A part which has already been encoded

instance ASN1Elem ASN1P where
    asn1Container :: ASN1ConstructionType -> ASN1Stream ASN1P -> ASN1Stream ASN1P
asn1Container ASN1ConstructionType
ty ASN1Stream ASN1P
f = (ASN1ConstructionType -> [ASN1P] -> ASN1P
ASN1Container ASN1ConstructionType
ty (ASN1Stream ASN1P
f []) forall a. a -> [a] -> [a]
:)
    gMany :: [ASN1] -> ASN1Stream ASN1P
gMany [ASN1]
asn1 = ([ASN1] -> ASN1P
ASN1Prim [ASN1]
asn1 forall a. a -> [a] -> [a]
:)
    gOne :: ASN1 -> ASN1Stream ASN1P
gOne = forall e. ASN1Elem e => [ASN1] -> ASN1Stream e
gMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])

-- | Prepend a list of 'ASN1P'.
type ASN1PS = ASN1Stream ASN1P

-- | Encode to ASN.1 a list of 'ASN1P' elements.  Outer encoding will be DER,
-- but partially encoded inner 'ASN1Encoded' elements many have any encoding.
pEncode :: [ASN1P] -> ByteString
pEncode :: [ASN1P] -> ByteString
pEncode [ASN1P]
x = let (Int
_, ByteString -> ByteString
f) = [ASN1P] -> (Int, ByteString -> ByteString)
run [ASN1P]
x in ByteString -> ByteString
f forall a. ByteArray a => a
B.empty
  where
    run :: [ASN1P] -> (Int, ByteString -> ByteString)
run []                   = (Int
0, forall a. a -> a
id)
    run (ASN1Prim [ASN1]
asn1 : [ASN1P]
as) = (forall ba. ByteArrayAccess ba => ba -> Int
B.length ByteString
p forall a. Num a => a -> a -> a
+ Int
r, forall bs. ByteArray bs => bs -> bs -> bs
B.append ByteString
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ps)
      where p :: ByteString
p       = forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER [ASN1]
asn1
            (Int
r, ByteString -> ByteString
ps) = [ASN1P] -> (Int, ByteString -> ByteString)
run [ASN1P]
as
    run (ASN1Encoded ByteString
p : [ASN1P]
as) = (forall ba. ByteArrayAccess ba => ba -> Int
B.length ByteString
p forall a. Num a => a -> a -> a
+ Int
r, forall bs. ByteArray bs => bs -> bs -> bs
B.append ByteString
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ps)
      where (Int
r, ByteString -> ByteString
ps) = [ASN1P] -> (Int, ByteString -> ByteString)
run [ASN1P]
as
    run (ASN1Container ASN1ConstructionType
ty [ASN1P]
children : [ASN1P]
as) =
        (forall ba. ByteArrayAccess ba => ba -> Int
B.length ByteString
header forall a. Num a => a -> a -> a
+ Int
l forall a. Num a => a -> a -> a
+ Int
r, forall bs. ByteArray bs => bs -> bs -> bs
B.append ByteString
header forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ps)
      where (Int
l, ByteString -> ByteString
p)  = [ASN1P] -> (Int, ByteString -> ByteString)
run [ASN1P]
children
            (Int
r, ByteString -> ByteString
ps) = [ASN1P] -> (Int, ByteString -> ByteString)
run [ASN1P]
as
            header :: ByteString
header  = [ASN1Event] -> ByteString
toByteString [ASN1Header -> ASN1Event
Header forall a b. (a -> b) -> a -> b
$ ASN1Class -> Int -> Bool -> ASN1Length -> ASN1Header
ASN1Header ASN1Class
cl Int
tg Bool
True forall a b. (a -> b) -> a -> b
$ Int -> ASN1Length
makeLen Int
l]
            (ASN1Class
cl, Int
tg) =
                case ASN1ConstructionType
ty of
                    Container ASN1Class
tyClass Int
tyTag -> (ASN1Class
tyClass, Int
tyTag)
                    ASN1ConstructionType
Sequence -> (ASN1Class
Universal, Int
0x10)
                    ASN1ConstructionType
Set -> (ASN1Class
Universal, Int
0x11)

    makeLen :: Int -> ASN1Length
makeLen Int
len
        | Int
len forall a. Ord a => a -> a -> Bool
< Int
0x80 = Int -> ASN1Length
LenShort Int
len
        | Bool
otherwise  = Int -> Int -> ASN1Length
LenLong (forall {t} {a}. (Num a, Integral t) => t -> a
nbBytes Int
len) Int
len
    nbBytes :: t -> a
nbBytes t
nb = if t
nb forall a. Ord a => a -> a -> Bool
> t
255 then a
1 forall a. Num a => a -> a -> a
+ t -> a
nbBytes (t
nb forall a. Integral a => a -> a -> a
`div` t
256) else a
1

-- | Generate a 'Null' ASN.1 element.
gNull :: ASN1Elem e => ASN1Stream e
gNull :: forall e. ASN1Elem e => ASN1Stream e
gNull = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne ASN1
Null

-- | Generate an 'IntVal' ASN.1 element.
gIntVal :: ASN1Elem e => Integer -> ASN1Stream e
gIntVal :: forall e. ASN1Elem e => Integer -> ASN1Stream e
gIntVal = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ASN1
IntVal

-- | Generate an 'OID' ASN.1 element.
gOID :: ASN1Elem e => OID -> ASN1Stream e
gOID :: forall e. ASN1Elem e => OID -> ASN1Stream e
gOID = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. OID -> ASN1
OID

-- | Generate an 'ASN1String' ASN.1 element.
gASN1String :: ASN1Elem e => ASN1CharacterString -> ASN1Stream e
gASN1String :: forall e. ASN1Elem e => ASN1CharacterString -> ASN1Stream e
gASN1String = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1CharacterString -> ASN1
ASN1String

-- | Generate an @BMPString@ ASN.1 element.
gBMPString :: ASN1Elem e => String -> ASN1Stream e
gBMPString :: forall e. ASN1Elem e => String -> ASN1Stream e
gBMPString = forall e. ASN1Elem e => ASN1CharacterString -> ASN1Stream e
gASN1String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1StringEncoding -> String -> ASN1CharacterString
asn1CharacterString ASN1StringEncoding
BMP

-- | Generate an 'OctetString' ASN.1 element.
gOctetString :: ASN1Elem e => ByteString -> ASN1Stream e
gOctetString :: forall e. ASN1Elem e => ByteString -> ASN1Stream e
gOctetString = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ASN1
OctetString

-- | Generate a 'BitString' ASN.1 element.
gBitString :: ASN1Elem e => BitArray -> ASN1Stream e
gBitString :: forall e. ASN1Elem e => BitArray -> ASN1Stream e
gBitString = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitArray -> ASN1
BitString

-- | Generate an 'ASN1Time' ASN.1 element.
gASN1Time :: ASN1Elem e
          => ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1Stream e
gASN1Time :: forall e.
ASN1Elem e =>
ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1Stream e
gASN1Time ASN1TimeType
a DateTime
b Maybe TimezoneOffset
c = forall e. ASN1Elem e => ASN1 -> ASN1Stream e
gOne (ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1
ASN1Time ASN1TimeType
a DateTime
b Maybe TimezoneOffset
c)

-- | Generate ASN.1 for an optional value.
optASN1S :: Maybe a -> (a -> ASN1Stream e) -> ASN1Stream e
optASN1S :: forall a e. Maybe a -> (a -> ASN1Stream e) -> ASN1Stream e
optASN1S Maybe a
Nothing    a -> ASN1Stream e
_  = forall a. a -> a
id
optASN1S (Just a
val) a -> ASN1Stream e
fn = a -> ASN1Stream e
fn a
val

-- | Generate ASN.1 for a part of the stream which is already encoded.
gEncoded :: ByteString -> ASN1PS
gEncoded :: ByteString -> ASN1Stream ASN1P
gEncoded = (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ASN1P
ASN1Encoded

-- | Encode the ASN.1 stream to DER format (except for inner parts that are
-- already encoded and may use another format).
encodeASN1S :: ASN1PS -> ByteString
encodeASN1S :: ASN1Stream ASN1P -> ByteString
encodeASN1S ASN1Stream ASN1P
asn1 = [ASN1P] -> ByteString
pEncode (ASN1Stream ASN1P
asn1 [])