1-- |
2-- Module      : Data.X509.Ext
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- extension processing module.
9--
10{-# LANGUAGE FlexibleContexts #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12module Data.X509.Ext
13    ( Extension(..)
14    -- * Common extension usually found in x509v3
15    , ExtBasicConstraints(..)
16    , ExtKeyUsage(..)
17    , ExtKeyUsageFlag(..)
18    , ExtExtendedKeyUsage(..)
19    , ExtKeyUsagePurpose(..)
20    , ExtSubjectKeyId(..)
21    , ExtSubjectAltName(..)
22    , ExtAuthorityKeyId(..)
23    , ExtCrlDistributionPoints(..)
24    , ExtNetscapeComment(..)
25    , AltName(..)
26    , DistributionPoint(..)
27    , ReasonFlag(..)
28    -- * Accessor turning extension into a specific one
29    , extensionGet
30    , extensionGetE
31    , extensionDecode
32    , extensionEncode
33    ) where
34
35import qualified Data.ByteString as B
36import qualified Data.ByteString.Char8 as BC
37import Data.ASN1.Types
38import Data.ASN1.Parse
39import Data.ASN1.Encoding
40import Data.ASN1.BinaryEncoding
41import Data.ASN1.BitArray
42import Data.Proxy
43import Data.List (find)
44import Data.X509.ExtensionRaw
45import Data.X509.DistinguishedName
46import Control.Applicative
47import Control.Monad
48
49-- | key usage flag that is found in the key usage extension field.
50data ExtKeyUsageFlag =
51      KeyUsage_digitalSignature -- (0)
52    | KeyUsage_nonRepudiation   -- (1) recent X.509 ver have renamed this bit to contentCommitment
53    | KeyUsage_keyEncipherment  -- (2)
54    | KeyUsage_dataEncipherment -- (3)
55    | KeyUsage_keyAgreement     -- (4)
56    | KeyUsage_keyCertSign      -- (5)
57    | KeyUsage_cRLSign          -- (6)
58    | KeyUsage_encipherOnly     -- (7)
59    | KeyUsage_decipherOnly     -- (8)
60    deriving (Show,Eq,Ord,Enum)
61
62{-
63-- RFC 5280
64oidDistributionPoints, oidPolicies, oidPoliciesMapping :: OID
65oidPolicies           = [2,5,29,32]
66oidPoliciesMapping    = [2,5,29,33]
67-}
68
69-- | Extension class.
70--
71-- each extension have a unique OID associated, and a way
72-- to encode and decode an ASN1 stream.
73--
74-- Errata: turns out, the content is not necessarily ASN1,
75-- it could be data that is only parsable by the extension
76-- e.g. raw ascii string. Add method to parse and encode with
77-- ByteString
78class Extension a where
79    extOID           :: a -> OID
80    extHasNestedASN1 :: Proxy a -> Bool
81    extEncode        :: a -> [ASN1]
82    extDecode        :: [ASN1] -> Either String a
83
84    extDecodeBs :: B.ByteString -> Either String a
85    extDecodeBs = (either (Left . show) Right . decodeASN1' BER) >=> extDecode
86
87    extEncodeBs :: a -> B.ByteString
88    extEncodeBs = encodeASN1' DER . extEncode
89
90
91-- | Get a specific extension from a lists of raw extensions
92extensionGet :: Extension a => Extensions -> Maybe a
93extensionGet (Extensions Nothing)  = Nothing
94extensionGet (Extensions (Just l)) = findExt l
95  where findExt []     = Nothing
96        findExt (x:xs) = case extensionDecode x of
97                            Just (Right e) -> Just e
98                            _              -> findExt xs
99
100-- | Get a specific extension from a lists of raw extensions
101extensionGetE :: Extension a => Extensions -> Maybe (Either String a)
102extensionGetE (Extensions Nothing)  = Nothing
103extensionGetE (Extensions (Just l)) = findExt l
104  where findExt []     = Nothing
105        findExt (x:xs) = case extensionDecode x of
106                            Just r         -> Just r
107                            _              -> findExt xs
108
109-- | Try to decode an ExtensionRaw.
110--
111-- If this function return:
112-- * Nothing, the OID doesn't match
113-- * Just Left, the OID matched, but the extension couldn't be decoded
114-- * Just Right, the OID matched, and the extension has been succesfully decoded
115extensionDecode :: forall a . Extension a => ExtensionRaw -> Maybe (Either String a)
116extensionDecode er@(ExtensionRaw oid _ content)
117    | extOID (undefined :: a) /= oid      = Nothing
118    | extHasNestedASN1 (Proxy :: Proxy a) = Just (tryExtRawASN1 er >>= extDecode)
119    | otherwise                           = Just (extDecodeBs content)
120
121-- | Encode an Extension to extensionRaw
122extensionEncode :: forall a . Extension a => Bool -> a -> ExtensionRaw
123extensionEncode critical ext
124    | extHasNestedASN1 (Proxy :: Proxy a) = ExtensionRaw (extOID ext) critical (encodeASN1' DER $ extEncode ext)
125    | otherwise                           = ExtensionRaw (extOID ext) critical (extEncodeBs ext)
126
127-- | Basic Constraints
128data ExtBasicConstraints = ExtBasicConstraints Bool (Maybe Integer)
129    deriving (Show,Eq)
130
131instance Extension ExtBasicConstraints where
132    extOID = const [2,5,29,19]
133    extHasNestedASN1 = const True
134    extEncode (ExtBasicConstraints b Nothing)  = [Start Sequence,Boolean b,End Sequence]
135    extEncode (ExtBasicConstraints b (Just i)) = [Start Sequence,Boolean b,IntVal i,End Sequence]
136
137    extDecode [Start Sequence,Boolean b,IntVal v,End Sequence]
138        | v >= 0    = Right (ExtBasicConstraints b (Just v))
139        | otherwise = Left "invalid pathlen"
140    extDecode [Start Sequence,Boolean b,End Sequence] = Right (ExtBasicConstraints b Nothing)
141    extDecode [Start Sequence,End Sequence] = Right (ExtBasicConstraints False Nothing)
142    extDecode _ = Left "unknown sequence"
143
144-- | Describe key usage
145data ExtKeyUsage = ExtKeyUsage [ExtKeyUsageFlag]
146    deriving (Show,Eq)
147
148instance Extension ExtKeyUsage where
149    extOID = const [2,5,29,15]
150    extHasNestedASN1 = const True
151    extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags]
152    extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits
153    extDecode _ = Left "unknown sequence"
154
155-- | Key usage purposes for the ExtendedKeyUsage extension
156data ExtKeyUsagePurpose =
157      KeyUsagePurpose_ServerAuth
158    | KeyUsagePurpose_ClientAuth
159    | KeyUsagePurpose_CodeSigning
160    | KeyUsagePurpose_EmailProtection
161    | KeyUsagePurpose_TimeStamping
162    | KeyUsagePurpose_OCSPSigning
163    | KeyUsagePurpose_Unknown OID
164    deriving (Show,Eq,Ord)
165
166extKeyUsagePurposedOID :: [(OID, ExtKeyUsagePurpose)]
167extKeyUsagePurposedOID =
168    [(keyUsagePurposePrefix 1, KeyUsagePurpose_ServerAuth)
169    ,(keyUsagePurposePrefix 2, KeyUsagePurpose_ClientAuth)
170    ,(keyUsagePurposePrefix 3, KeyUsagePurpose_CodeSigning)
171    ,(keyUsagePurposePrefix 4, KeyUsagePurpose_EmailProtection)
172    ,(keyUsagePurposePrefix 8, KeyUsagePurpose_TimeStamping)
173    ,(keyUsagePurposePrefix 9, KeyUsagePurpose_OCSPSigning)]
174  where keyUsagePurposePrefix r = [1,3,6,1,5,5,7,3,r]
175
176-- | Extended key usage extension
177data ExtExtendedKeyUsage = ExtExtendedKeyUsage [ExtKeyUsagePurpose]
178    deriving (Show,Eq)
179
180instance Extension ExtExtendedKeyUsage where
181    extOID = const [2,5,29,37]
182    extHasNestedASN1 = const True
183    extEncode (ExtExtendedKeyUsage purposes) =
184        [Start Sequence] ++ map (OID . lookupRev) purposes ++ [End Sequence]
185      where lookupRev (KeyUsagePurpose_Unknown oid) = oid
186            lookupRev kup = maybe (error "unknown key usage purpose") fst $ find ((==) kup . snd) extKeyUsagePurposedOID
187    extDecode l = ExtExtendedKeyUsage `fmap` (flip runParseASN1 l $ onNextContainer Sequence $ getMany $ do
188        n <- getNext
189        case n of
190            OID o -> return $ maybe (KeyUsagePurpose_Unknown o) id $ lookup o extKeyUsagePurposedOID
191            _     -> error "invalid content in extended key usage")
192
193-- | Provide a way to identify a public key by a short hash.
194data ExtSubjectKeyId = ExtSubjectKeyId B.ByteString
195    deriving (Show,Eq)
196
197instance Extension ExtSubjectKeyId where
198    extOID = const [2,5,29,14]
199    extHasNestedASN1 = const True
200    extEncode (ExtSubjectKeyId o) = [OctetString o]
201    extDecode [OctetString o] = Right $ ExtSubjectKeyId o
202    extDecode _ = Left "unknown sequence"
203
204-- | Different naming scheme use by the extension.
205--
206-- Not all name types are available, missing:
207-- otherName
208-- x400Address
209-- directoryName
210-- ediPartyName
211-- registeredID
212--
213data AltName =
214      AltNameRFC822 String
215    | AltNameDNS String
216    | AltNameURI String
217    | AltNameIP  B.ByteString
218    | AltNameXMPP String
219    | AltNameDNSSRV String
220    deriving (Show,Eq,Ord)
221
222-- | Provide a way to supply alternate name that can be
223-- used for matching host name.
224data ExtSubjectAltName = ExtSubjectAltName [AltName]
225    deriving (Show,Eq,Ord)
226
227instance Extension ExtSubjectAltName where
228    extOID = const [2,5,29,17]
229    extHasNestedASN1 = const True
230    extEncode (ExtSubjectAltName names) = encodeGeneralNames names
231    extDecode l = runParseASN1 (ExtSubjectAltName <$> parseGeneralNames) l
232
233-- | Provide a mean to identify the public key corresponding to the private key
234-- used to signed a certificate.
235data ExtAuthorityKeyId = ExtAuthorityKeyId B.ByteString
236    deriving (Show,Eq)
237
238instance Extension ExtAuthorityKeyId where
239    extOID _ = [2,5,29,35]
240    extHasNestedASN1 = const True
241    extEncode (ExtAuthorityKeyId keyid) =
242        [Start Sequence,Other Context 0 keyid,End Sequence]
243    extDecode [Start Sequence,Other Context 0 keyid,End Sequence] =
244        Right $ ExtAuthorityKeyId keyid
245    extDecode _ = Left "unknown sequence"
246
247-- | Identify how CRL information is obtained
248data ExtCrlDistributionPoints = ExtCrlDistributionPoints [DistributionPoint]
249    deriving (Show,Eq)
250
251-- | Reason flag for the CRL
252data ReasonFlag =
253      Reason_Unused
254    | Reason_KeyCompromise
255    | Reason_CACompromise
256    | Reason_AffiliationChanged
257    | Reason_Superseded
258    | Reason_CessationOfOperation
259    | Reason_CertificateHold
260    | Reason_PrivilegeWithdrawn
261    | Reason_AACompromise
262    deriving (Show,Eq,Ord,Enum)
263
264-- | Distribution point as either some GeneralNames or a DN
265data DistributionPoint =
266      DistributionPointFullName [AltName]
267    | DistributionNameRelative DistinguishedName
268    deriving (Show,Eq)
269
270instance Extension ExtCrlDistributionPoints where
271    extOID _ = [2,5,29,31]
272    extHasNestedASN1 = const True
273    extEncode = error "extEncode ExtCrlDistributionPoints unimplemented"
274    extDecode = error "extDecode ExtCrlDistributionPoints unimplemented"
275    --extEncode (ExtCrlDistributionPoints )
276
277parseGeneralNames :: ParseASN1 [AltName]
278parseGeneralNames = onNextContainer Sequence $ getMany getAddr
279  where
280        getAddr = do
281            m <- onNextContainerMaybe (Container Context 0) getComposedAddr
282            case m of
283                Nothing -> getSimpleAddr
284                Just r  -> return r
285        getComposedAddr = do
286            n <- getNext
287            case n of
288                OID [1,3,6,1,5,5,7,8,5] -> do -- xmpp addr
289                    c <- getNextContainerMaybe (Container Context 0)
290                    case c of
291                        Just [ASN1String cs] ->
292                            case asn1CharacterToString cs of
293                                Nothing -> throwParseError ("GeneralNames: invalid string for XMPP Addr")
294                                Just s  -> return $ AltNameXMPP s
295                        _ -> throwParseError ("GeneralNames: expecting string for XMPP Addr got: " ++ show c)
296                OID [1,3,6,1,5,5,7,8,7] -> do -- DNSSRV addr
297                    c <- getNextContainerMaybe (Container Context 0)
298                    case c of
299                        Just [ASN1String cs] ->
300                            case asn1CharacterToString cs of
301                                Nothing -> throwParseError ("GeneralNames: invalid string for DNSSrv Addr")
302                                Just s  -> return $ AltNameDNSSRV s
303                        _ -> throwParseError ("GeneralNames: expecting string for DNSSRV Addr got: " ++ show c)
304                OID unknown -> throwParseError ("GeneralNames: unknown OID " ++ show unknown)
305                _           -> throwParseError ("GeneralNames: expecting OID but got " ++ show n)
306
307        getSimpleAddr = do
308            n <- getNext
309            case n of
310                (Other Context 1 b) -> return $ AltNameRFC822 $ BC.unpack b
311                (Other Context 2 b) -> return $ AltNameDNS $ BC.unpack b
312                (Other Context 6 b) -> return $ AltNameURI $ BC.unpack b
313                (Other Context 7 b) -> return $ AltNameIP  b
314                _                   -> throwParseError ("GeneralNames: not coping with unknown stream " ++ show n)
315
316encodeGeneralNames :: [AltName] -> [ASN1]
317encodeGeneralNames names =
318    [Start Sequence]
319    ++ concatMap encodeAltName names
320    ++ [End Sequence]
321  where encodeAltName (AltNameRFC822 n) = [Other Context 1 $ BC.pack n]
322        encodeAltName (AltNameDNS n)    = [Other Context 2 $ BC.pack n]
323        encodeAltName (AltNameURI n)    = [Other Context 6 $ BC.pack n]
324        encodeAltName (AltNameIP n)     = [Other Context 7 $ n]
325        encodeAltName (AltNameXMPP n)   = [Start (Container Context 0),OID[1,3,6,1,5,5,7,8,5]
326                                          ,Start (Container Context 0), ASN1String $ asn1CharacterString UTF8 n, End (Container Context 0)
327                                          ,End (Container Context 0)]
328        encodeAltName (AltNameDNSSRV n) = [Start (Container Context 0),OID[1,3,6,1,5,5,7,8,5]
329                                          ,Start (Container Context 0), ASN1String $ asn1CharacterString UTF8 n, End (Container Context 0)
330                                          ,End (Container Context 0)]
331
332bitsToFlags :: Enum a => BitArray -> [a]
333bitsToFlags bits = concat $ flip map [0..(bitArrayLength bits-1)] $ \i -> do
334        let isSet = bitArrayGetBit bits i
335        if isSet then [toEnum $ fromIntegral i] else []
336
337flagsToBits :: Enum a => [a] -> BitArray
338flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags
339  where bitArrayEmpty = toBitArray (B.pack [0,0]) 7
340
341data ExtNetscapeComment = ExtNetscapeComment B.ByteString
342    deriving (Show,Eq)
343
344instance Extension ExtNetscapeComment where
345    extOID _ = [2,16,840,1,113730,1,13]
346    extHasNestedASN1 = const False
347    extEncode = error "Extension: Netscape Comment do not contain nested ASN1"
348    extDecode = error "Extension: Netscape Comment do not contain nested ASN1"
349    extEncodeBs (ExtNetscapeComment b) = b
350    extDecodeBs = Right . ExtNetscapeComment
351