-- |
-- 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)