Add basic macaroon verification

[github/fretlink/hmacaroons.git] / src / Crypto / Macaroon / Verifier.hs

diff --git a/src/Crypto/Macaroon/Verifier.hs b/src/Crypto/Macaroon/Verifier.hs
index e257f5f71d4a5edf098c8425d4f788ae19d93b5d..02cb448db340d2557b72b0486c8303bcd8987734 100644 (file)
--- a/src/Crypto/Macaroon/Verifier.hs
+++ b/src/Crypto/Macaroon/Verifier.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-|
 Module      : Crypto.Macaroon.Verifier
 Copyright   : (c) 2015 Julien Tanguy
@@ -11,7 +12,17 @@ Portability : portable
 
 
 -}
-module Crypto.Macaroon.Verifier where
+module Crypto.Macaroon.Verifier (
+    Verified(..)
+  , CaveatVerifier
+  , (<???>)
+  , verifyMacaroon
+  , verifySig
+  , verifyExact
+  , verifyFun
+  , module Data.Attoparsec.ByteString.Char8
+  , verifyCavs
+) where
 
 
 import           Crypto.Hash
@@ -19,16 +30,62 @@ import           Data.Bool
 import qualified Data.ByteString            as BS
 import           Data.Byteable
 import           Data.Foldable
+import           Data.Function
+import           Data.Maybe
+import           Data.Traversable
+import Data.Attoparsec.ByteString
+import Data.Attoparsec.ByteString.Char8
 
 import           Crypto.Macaroon.Internal
 
 
 -- | Opaque datatype for now. Might need more explicit errors
-data VResult = VSuccess | VFailure deriving (Show,Eq)
+data Verified = Ok | Failed deriving (Show,Eq)
 
-verifySig :: Key -> Macaroon -> VResult
-verifySig k m = bool VFailure VSuccess $
+instance Monoid Verified where
+  mempty = Ok
+  mappend Ok Ok = Ok
+  mappend _ _ = Failed
+
+
+data CaveatVerifier = CV { vFun :: Caveat -> Maybe Verified , helpText :: String}
+
+instance Eq CaveatVerifier where
+  (==) = (==) `on` helpText
+
+instance Show CaveatVerifier where
+    show = helpText
+
+(<???>) :: (Caveat -> Maybe Verified) -> String -> CaveatVerifier
+f <???> t = CV f t
+
+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)
+
+verifyMacaroon :: Key -> [CaveatVerifier] -> Macaroon -> Verified
+verifyMacaroon secret verifiers m = verifySig secret m `mappend` verifyCavs verifiers m
+
+
+verifyCavs :: [CaveatVerifier] -> Macaroon -> Verified
+verifyCavs verifiers m = foldMap (\c -> fromMaybe Failed $ foldMap (($ c) . vFun) 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