    -- |
    -- Module      : Data.X509.Ext
    -- License     : BSD-style
    -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
    -- Stability   : experimental
    -- Portability : unknown
    --
    -- extension processing module.
    --
    module Data.X509.Ext
        ( Extension(..)
        -- * Common extension usually found in x509v3
        , ExtBasicConstraints(..)
        , ExtKeyUsage(..)
        , ExtKeyUsageFlag(..)
        , ExtSubjectKeyId(..)
        , ExtSubjectAltName(..)
        , ExtAuthorityKeyId(..)
        , ExtCrlDistributionPoints(..)
        , AltName(..)
        , DistributionPoint(..)
        , ReasonFlag(..)
        -- * Accessor turning extension into a specific one
        , extensionGet
        , extensionDecode
        ) where

    import qualified Data.ByteString as B
    import qualified Data.ByteString.Char8 as BC
    import Data.ASN1.Types
    import Data.ASN1.BitArray
    import Data.X509.Internal
    import Data.X509.ExtensionRaw
    import Data.X509.DistinguishedName
    import Control.Applicative
    import Control.Monad.Error

    -- | key usage flag that is found in the key usage extension field.
    data ExtKeyUsageFlag =
          KeyUsage_digitalSignature -- (0)
        | KeyUsage_nonRepudiation   -- (1) recent X.509 ver have renamed this bit to contentCommitment
        | KeyUsage_keyEncipherment  -- (2)
        | KeyUsage_dataEncipherment -- (3)
        | KeyUsage_keyAgreement     -- (4)
        | KeyUsage_keyCertSign      -- (5)
        | KeyUsage_cRLSign          -- (6)
        | KeyUsage_encipherOnly     -- (7)
        | KeyUsage_decipherOnly     -- (8)
        deriving (Show,Eq,Ord,Enum)

    {-
    -- RFC 5280
    oidDistributionPoints, oidPolicies, oidPoliciesMapping :: OID
    oidPolicies           = [2,5,29,32]
    oidPoliciesMapping    = [2,5,29,33]
    -}

    -- | Extension class.
    --
    -- each extension have a unique OID associated, and a way
    -- to encode and decode an ASN1 stream.
    class Extension a where
        extOID    :: a -> OID
        extEncode :: a -> [ASN1]
        extDecode :: [ASN1] -> Either String a

    -- | Get a specific extension from a lists of raw extensions
    extensionGet :: Extension a => Extensions -> Maybe a
    extensionGet (Extensions Nothing)  = Nothing
    extensionGet (Extensions (Just l)) = findExt l
      where findExt []     = Nothing
            findExt (x:xs) = case extensionDecode x of
                                Just (Right e) -> Just e
                                _              -> findExt xs

    -- | Try to decode an ExtensionRaw.
    --
    -- If this function return:
    -- * Nothing, the OID doesn't match
    -- * Just Left, the OID matched, but the extension couldn't be decoded
    -- * Just Right, the OID matched, and the extension has been succesfully decoded
    extensionDecode :: Extension a => ExtensionRaw -> Maybe (Either String a)
    extensionDecode = doDecode undefined
      where doDecode :: Extension a => a -> ExtensionRaw -> Maybe (Either String a)
            doDecode dummy (ExtensionRaw oid _ asn1)
                | extOID dummy == oid = Just (extDecode asn1)
                | otherwise           = Nothing

    -- | Basic Constraints
    data ExtBasicConstraints = ExtBasicConstraints Bool (Maybe Integer)
        deriving (Show,Eq)

    instance Extension ExtBasicConstraints where
        extOID = const [2,5,29,19]
        extEncode (ExtBasicConstraints b Nothing)  = [Start Sequence,Boolean b,End Sequence]
        extEncode (ExtBasicConstraints b (Just i)) = [Start Sequence,Boolean b,IntVal i,End Sequence]

        extDecode [Start Sequence,Boolean b,IntVal v,End Sequence]
            | v >= 0    = Right (ExtBasicConstraints b (Just v))
            | otherwise = Left "invalid pathlen"
        extDecode [Start Sequence,Boolean b,End Sequence] = Right (ExtBasicConstraints b Nothing)
        extDecode [Start Sequence,End Sequence] = Right (ExtBasicConstraints False Nothing)
        extDecode _ = Left "unknown sequence"

    -- | Describe key usage
    data ExtKeyUsage = ExtKeyUsage [ExtKeyUsageFlag]
        deriving (Show,Eq)

    instance Extension ExtKeyUsage where
        extOID = const [2,5,29,15]
        extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags]
        extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits
        extDecode _ = Left "unknown sequence"

    -- | Provide a way to identify a public key by a short hash.
    data ExtSubjectKeyId = ExtSubjectKeyId B.ByteString
        deriving (Show,Eq)

    instance Extension ExtSubjectKeyId where
        extOID = const [2,5,29,14]
        extEncode (ExtSubjectKeyId o) = [OctetString o]
        extDecode [OctetString o] = Right $ ExtSubjectKeyId o
        extDecode _ = Left "unknown sequence"

    -- | Different naming scheme use by the extension.
    --
    -- Not all name types are available, missing:
    -- otherName
    -- x400Address
    -- directoryName
    -- ediPartyName
    -- registeredID
    --
    data AltName =
          AltNameRFC822 String
        | AltNameDNS String
        | AltNameURI String
        | AltNameIP  B.ByteString
        deriving (Show,Eq,Ord)

    -- | Provide a way to supply alternate name that can be
    -- used for matching host name.
    data ExtSubjectAltName = ExtSubjectAltName [AltName]
        deriving (Show,Eq,Ord)

    instance Extension ExtSubjectAltName where
        extOID = const [2,5,29,17]
        extEncode (ExtSubjectAltName names) = encodeGeneralNames names
        extDecode l = runParseASN1 (ExtSubjectAltName <$> parseGeneralNames) l

    -- | Provide a mean to identify the public key corresponding to the private key
    -- used to signed a certificate.
    data ExtAuthorityKeyId = ExtAuthorityKeyId B.ByteString
        deriving (Show,Eq)

    instance Extension ExtAuthorityKeyId where
        extOID _ = [2,5,29,35]
        extEncode (ExtAuthorityKeyId keyid) =
            [Start Sequence,Other Context 0 keyid,End Sequence]
        extDecode [Start Sequence,Other Context 0 keyid,End Sequence] =
            Right $ ExtAuthorityKeyId keyid
        extDecode _ = Left "unknown sequence"

    -- | Identify how CRL information is obtained
    data ExtCrlDistributionPoints = ExtCrlDistributionPoints [DistributionPoint]
        deriving (Show,Eq)

    -- | Reason flag for the CRL
    data ReasonFlag =
          Reason_Unused
        | Reason_KeyCompromise
        | Reason_CACompromise
        | Reason_AffiliationChanged
        | Reason_Superseded
        | Reason_CessationOfOperation
        | Reason_CertificateHold
        | Reason_PrivilegeWithdrawn
        | Reason_AACompromise
        deriving (Show,Eq,Ord,Enum)

    -- | Distribution point as either some GeneralNames or a DN
    data DistributionPoint =
          DistributionPointFullName [AltName]
        | DistributionNameRelative DistinguishedName
        deriving (Show,Eq)

    instance Extension ExtCrlDistributionPoints where
        extOID _ = [2,5,29,31]
        extEncode = undefined
        extDecode = undefined
        --extEncode (ExtCrlDistributionPoints )

    parseGeneralNames :: ParseASN1 [AltName]
    parseGeneralNames = do
        c <- getNextContainer Sequence
        r <- sequence $ map toStringy c
        return r
      where
            toStringy (Other Context 1 b) = return $ AltNameRFC822 $ BC.unpack b
            toStringy (Other Context 2 b) = return $ AltNameDNS $ BC.unpack b
            toStringy (Other Context 6 b) = return $ AltNameURI $ BC.unpack b
            toStringy (Other Context 7 b) = return $ AltNameIP  b
            toStringy b                   = throwError ("GeneralNames: not coping with anything else " ++ show b)

    encodeGeneralNames :: [AltName] -> [ASN1]
    encodeGeneralNames names =
        [Start Sequence]
        ++ map encodeAltName names
        ++ [End Sequence]
      where encodeAltName (AltNameRFC822 n) = Other Context 1 $ BC.pack n
            encodeAltName (AltNameDNS n)    = Other Context 2 $ BC.pack n
            encodeAltName (AltNameURI n)    = Other Context 6 $ BC.pack n
            encodeAltName (AltNameIP n)     = Other Context 7 $ n

    bitsToFlags :: Enum a => BitArray -> [a]
    bitsToFlags bits = concat $ flip map [0..(bitArrayLength bits-1)] $ \i -> do
            let isSet = bitArrayGetBit bits i
            if isSet then [toEnum $ fromIntegral i] else []

    flagsToBits :: Enum a => [a] -> BitArray
    flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags
            where bitArrayEmpty = BitArray 2 (B.pack [0,0])