]>
Commit | Line | Data |
---|---|---|
86f38823 JT |
1 | {-# LANGUAGE OverloadedStrings #-} |
2 | {-# LANGUAGE RankNTypes #-} | |
7f9f7386 JT |
3 | {-| |
4 | Module : Crypto.Macaroon.Verifier.Internal | |
5 | Copyright : (c) 2015 Julien Tanguy | |
6 | License : BSD3 | |
7 | ||
8 | Maintainer : julien.tanguy@jhome.fr | |
9 | Stability : experimental | |
10 | Portability : portable | |
11 | ||
12 | ||
13 | ||
14 | -} | |
15 | module Crypto.Macaroon.Verifier.Internal where | |
16 | ||
17 | import Control.Monad | |
18 | import Control.Monad.IO.Class | |
19 | import Crypto.Hash | |
20 | import Data.Bool | |
21 | import Data.Byteable | |
86f38823 | 22 | import qualified Data.ByteString as BS |
7f9f7386 JT |
23 | import Data.Either |
24 | import Data.Either.Validation | |
25 | import Data.Foldable | |
26 | import Data.Maybe | |
86f38823 | 27 | import Data.Monoid |
7f9f7386 JT |
28 | |
29 | import Crypto.Macaroon.Internal | |
30 | ||
86f38823 JT |
31 | -- | Type representing different validation errors. |
32 | -- Only 'ParseError' and 'ValidatorError' are exported, 'SigMismatch' and | |
33 | -- 'NoVerifier' are used internally and should not be used by the user | |
34 | data ValidationError = SigMismatch -- ^ Signatures do not match | |
35 | | NoVerifier -- ^ No verifier can handle a given caveat | |
36 | | ParseError String -- ^ A verifier had a parse error | |
37 | | ValidatorError String -- ^ A verifier failed | |
38 | deriving (Show,Eq) | |
7f9f7386 | 39 | |
86f38823 JT |
40 | -- | The 'Monoid' instance is written so 'SigMismatch' is an annihilator, |
41 | -- and 'NoVerifier' is the identity element | |
7f9f7386 JT |
42 | instance Monoid ValidationError where |
43 | mempty = NoVerifier | |
44 | NoVerifier `mappend` e = e | |
45 | e `mappend` NoVerifier = e | |
46 | SigMismatch `mappend` _ = SigMismatch | |
47 | _ `mappend` SigMismatch = SigMismatch | |
48 | (ValidatorError e) `mappend` (ParseError _) = ValidatorError e | |
49 | (ParseError _) `mappend` (ValidatorError e) = ValidatorError e | |
50 | ||
bf31e290 | 51 | -- | Check that the given macaroon has a correct signature |
7f9f7386 JT |
52 | verifySig :: Key -> Macaroon -> Either ValidationError Macaroon |
53 | verifySig k m = bool (Left SigMismatch) (Right m) $ | |
54 | signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m) | |
55 | where | |
56 | hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) | |
57 | derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) | |
58 | ||
86f38823 | 59 | -- | Given a list of verifiers, verify each caveat of the given macaroon |
7f9f7386 | 60 | verifyCavs :: MonadIO m |
86f38823 | 61 | => [Caveat -> m (Maybe (Either ValidationError ()))] |
7f9f7386 JT |
62 | -> Macaroon |
63 | -> m (Either ValidationError Macaroon) | |
64 | verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m) | |
65 | where | |
66 | {- | |
67 | - validateCaveat :: Caveat -> m (Validation String Caveat) | |
68 | - We can use fromJust here safely since we use a `Just Failure` as a | |
69 | - starting value for the foldM. We are guaranteed to have a `Just something` | |
70 | - from it. | |
71 | -} | |
86f38823 | 72 | validateCaveat c = fmap (const c) . fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers |
7f9f7386 JT |
73 | -- defErr :: Caveat -> Maybe (Validation String Caveat) |
74 | defErr c = Just $ Failure NoVerifier | |
75 | -- gatherEithers :: [Validation String Caveat] -> Either String Caveat | |
76 | gatherEithers vs = case partitionEithers . map validationToEither $ vs of | |
77 | ([],_) -> Right m | |
78 | (errs,_) -> Left (mconcat errs) |