blob: 012d156454f243f753c14547b4e908981fe3d61d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-|
Module : Crypto.Macaroon.Verifier
Copyright : (c) 2015 Julien Tanguy
License : BSD3
Maintainer : julien.tanguy@jhome.fr
Stability : experimental
Portability : portable
-}
module Crypto.Macaroon.Verifier (
Verified(..)
, verifySig
, verifyExact
, verifyFun
, verifyCavs
-- , module Data.Attoparsec.ByteString
, module Data.Attoparsec.ByteString.Char8
) where
import Crypto.Hash
import Data.Bool
import qualified Data.ByteString as BS
import Data.Byteable
import Data.Foldable
import Data.Maybe
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8
import Crypto.Macaroon.Internal
-- | Opaque datatype for now. Might need more explicit errors
data Verified = Ok | Failed deriving (Show,Eq)
instance Monoid Verified where
mempty = Ok
mappend Ok Ok = Ok
mappend _ _ = Failed
type CaveatVerifier = Caveat -> Maybe Verified
verifySig :: Key -> Macaroon -> Verified
verifySig k m = bool Failed Ok $
signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m)
where
hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256)
derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256)
verifyCavs :: [Caveat -> Maybe Verified] -> Macaroon -> Verified
verifyCavs verifiers m = mconcat $ map (\c -> mconcat . catMaybes $ map ($ c) verifiers) (caveats m)
verifyExact :: (Eq a) => Key -> a -> Parser a -> Caveat -> Maybe Verified
verifyExact k expected = verifyFun k (expected ==)
verifyFun :: Key -> (a -> Bool) -> Parser a -> Caveat -> Maybe Verified
verifyFun key f parser cav = if key `BS.isPrefixOf` cid cav then
case parseOnly kvparser (cid cav) of
Right v -> (bool Failed Ok . f) <$> Just v
Left _ -> Just Failed
else Nothing
where
kvparser = do
key <- string key
skipSpace
string "="
skipSpace
parser <* endOfInput
|
