aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/Crypto
diff options
context:
space:
mode:
authorJulien Tanguy <julien.tanguy@jhome.fr>2015-08-16 23:22:10 +0200
committerJulien Tanguy <julien.tanguy@jhome.fr>2015-08-16 23:22:10 +0200
commit7f9f7386fdbe8d19ef30ebd20939e67cc8bb145c (patch)
treeea8eea3c4e8c35db822b46e502049fc81e891aa3 /src/Crypto
parentc830f7c2cf925ce340f4097d76ea2a3bc94cb4a6 (diff)
downloadhmacaroons-7f9f7386fdbe8d19ef30ebd20939e67cc8bb145c.tar.gz
hmacaroons-7f9f7386fdbe8d19ef30ebd20939e67cc8bb145c.tar.zst
hmacaroons-7f9f7386fdbe8d19ef30ebd20939e67cc8bb145c.zip
Basic validation functions
Still needs testing [ci skip]
Diffstat (limited to 'src/Crypto')
-rw-r--r--src/Crypto/Macaroon/Verifier.hs81
-rw-r--r--src/Crypto/Macaroon/Verifier/Internal.hs74
2 files changed, 121 insertions, 34 deletions
diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index 713a971..7d5f094 100644
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -1,5 +1,8 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE RankNTypes #-} 2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TypeSynonymInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
3{-| 6{-|
4Module : Crypto.Macaroon.Verifier 7Module : Crypto.Macaroon.Verifier
5Copyright : (c) 2015 Julien Tanguy 8Copyright : (c) 2015 Julien Tanguy
@@ -13,50 +16,60 @@ Portability : portable
13 16
14-} 17-}
15module Crypto.Macaroon.Verifier ( 18module Crypto.Macaroon.Verifier (
16 Verifier 19 verify
17 , verifyMacaroon 20 , ValidationError(ValidatorError, ParseError)
18 , verifySig 21 -- , (.<), (.<=), (.==), (.>), (.>=)
19 -- , verifyExact 22 -- , module Data.Attoparsec.ByteString.Char8
20 -- , verifyFun
21 , module Data.Attoparsec.ByteString.Char8
22 , verifyCavs
23) where 23) where
24 24
25 25
26import Crypto.Hash 26import Control.Monad
27import Control.Monad.IO.Class
27import Data.Attoparsec.ByteString 28import Data.Attoparsec.ByteString
28import Data.Attoparsec.ByteString.Char8 29import Data.Attoparsec.ByteString.Char8
29import Data.Bool 30import Data.Bool
30import Data.Byteable
31import qualified Data.ByteString as BS 31import qualified Data.ByteString as BS
32import Data.Either 32import Data.Either.Combinators
33import Data.Either.Validation
34import Data.Foldable
35import Data.Function
36import Data.Maybe
37import Data.Traversable
38 33
39import Crypto.Macaroon.Internal 34import Crypto.Macaroon.Internal
35import Crypto.Macaroon.Verifier.Internal
40 36
41type Verifier = Caveat -> Maybe (Either String Caveat)
42 37
43verifySig :: Key -> Macaroon -> Either String Macaroon
44verifySig k m = bool (Left "Signatures do not match") (Right m) $
45 signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
46 where
47 hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
48 derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
49 38
50verifyMacaroon :: Key -> [Verifier] -> Macaroon -> Either String Macaroon
51verifyMacaroon secret verifiers m = verifySig secret m >>= verifyCavs verifiers
52 39
53verifyCavs :: [Verifier] -> Macaroon -> Either String Macaroon 40-- (.<) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
54verifyCavs verifiers m = case partitionEithers verifiedCaveats of 41-- (.<) = verifyOpBool "Greater or equal" (<) "<"
55 ([],_) -> Right m 42
56 (errs,_) -> Left (mconcat errs) 43-- (.<=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
57 where 44-- (.<=) = verifyOpBool "Strictly greater" (<=) "<="
58 verifiedCaveats = map (\c -> defaultFail c $ foldMap (fmap eitherToValidation . ($c)) verifiers) $ caveats m 45
59 defaultFail c = maybe (Left ("No validation for this caveat: " ++ show c)) validationToEither 46-- (.==) :: (MonadIO m, Eq a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
47-- (.==) = verifyOpBool "Not equal" (==) "="
48
49-- (.>) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
50-- (.>) = verifyOpBool "Less or equal" (>) ">"
51
52-- (.>=) :: (MonadIO m, Ord a, Parsable a) => Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
53-- (.>=) = verifyOpBool "Strictly less" (>=) ">="
60 54
61 55
62-- TODO: define API 56verify :: MonadIO m => Key -> [Caveat -> m (Maybe (Either ValidationError Caveat))] -> Macaroon -> m (Either ValidationError Macaroon)
57verify secret verifiers m = join <$> forM (verifySig secret m) (verifyCavs verifiers)
58
59
60-- verifyOpBool :: MonadIO m => String -> Parser a -> (a -> a -> Bool) -> BS.ByteString -> Key -> m a -> Caveat -> m (Maybe (Either ValidationError Caveat))
61-- verifyOpBool err p f op k val = verifyParser k valueParser $ \s -> do
62-- expected <- val
63-- return $ bool (Left $ ValidatorError err) (Right Win) =<< f expected <$> mapLeft ParseError (parseOnly p s)
64-- where
65-- valueParser = string op *> skipSpace *> takeByteString
66
67verifyParser :: (MonadIO m) => Key -> Parser a -> (a -> m (Either ValidationError Win)) -> Caveat -> m (Maybe (Either ValidationError Caveat))
68verifyParser k p f c = case parseOnly keyParser . cid $ c of
69 Left _ -> return Nothing
70 Right bs -> Just <$> case parseOnly p bs of
71 Left err -> return $ Left $ ParseError err
72 Right a -> fmap (const c) <$> f a
73 where
74 keyParser = string k *> skipSpace *> takeByteString
75
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)