aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/Crypto/Macaroon/Verifier/Internal.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Crypto/Macaroon/Verifier/Internal.hs')
-rw-r--r--src/Crypto/Macaroon/Verifier/Internal.hs74
1 files changed, 74 insertions, 0 deletions
diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs
new file mode 100644
index 0000000..63d826d
--- /dev/null
+++ b/src/Crypto/Macaroon/Verifier/Internal.hs
@@ -0,0 +1,74 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RankNTypes #-}
3{-|
4Module : Crypto.Macaroon.Verifier.Internal
5Copyright : (c) 2015 Julien Tanguy
6License : BSD3
7
8Maintainer : julien.tanguy@jhome.fr
9Stability : experimental
10Portability : portable
11
12
13
14-}
15module Crypto.Macaroon.Verifier.Internal where
16
17import Control.Monad
18import Control.Monad.IO.Class
19import Crypto.Hash
20import Data.Bool
21import Data.Byteable
22import qualified Data.ByteString as BS
23import Data.Either
24import Data.Either.Validation
25import Data.Foldable
26import Data.Maybe
27
28import Crypto.Macaroon.Internal
29
30data Win = Win
31
32data ValidationError = SigMismatch
33 | NoVerifier
34 | ParseError String
35 | ValidatorError String
36 deriving Show
37
38instance Monoid ValidationError where
39 mempty = NoVerifier
40 NoVerifier `mappend` e = e
41 e `mappend` NoVerifier = e
42 SigMismatch `mappend` _ = SigMismatch
43 _ `mappend` SigMismatch = SigMismatch
44 (ValidatorError e) `mappend` (ParseError _) = ValidatorError e
45 (ParseError _) `mappend` (ValidatorError e) = ValidatorError e
46
47
48verifySig :: Key -> Macaroon -> Either ValidationError Macaroon
49verifySig k m = bool (Left SigMismatch) (Right m) $
50 signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
51 where
52 hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
53 derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
54
55
56verifyCavs :: MonadIO m
57 => [Caveat -> m (Maybe (Either ValidationError Caveat))]
58 -> Macaroon
59 -> m (Either ValidationError Macaroon)
60verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
61 where
62 {-
63 - validateCaveat :: Caveat -> m (Validation String Caveat)
64 - We can use fromJust here safely since we use a `Just Failure` as a
65 - starting value for the foldM. We are guaranteed to have a `Just something`
66 - from it.
67 -}
68 validateCaveat c = fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers
69 -- defErr :: Caveat -> Maybe (Validation String Caveat)
70 defErr c = Just $ Failure NoVerifier
71 -- gatherEithers :: [Validation String Caveat] -> Either String Caveat
72 gatherEithers vs = case partitionEithers . map validationToEither $ vs of
73 ([],_) -> Right m
74 (errs,_) -> Left (mconcat errs)