Basic validation functions

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

diff --git a/src/Crypto/Macaroon/Verifier/Internal.hs b/src/Crypto/Macaroon/Verifier/Internal.hs
new file mode 100644 (file)
index 0000000..63d826d
--- /dev/null
+++ b/src/Crypto/Macaroon/Verifier/Internal.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-|
+Module      : Crypto.Macaroon.Verifier.Internal
+Copyright   : (c) 2015 Julien Tanguy
+License     : BSD3
+
+Maintainer  : julien.tanguy@jhome.fr
+Stability   : experimental
+Portability : portable
+
+
+
+-}
+module Crypto.Macaroon.Verifier.Internal where
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Crypto.Hash
+import           Data.Bool
+import           Data.Byteable
+import qualified Data.ByteString                  as BS
+import           Data.Either
+import           Data.Either.Validation
+import           Data.Foldable
+import           Data.Maybe
+
+import           Crypto.Macaroon.Internal
+
+data Win = Win
+
+data ValidationError = SigMismatch
+                     | NoVerifier
+                     | ParseError String
+                     | ValidatorError String
+                     deriving Show
+
+instance Monoid ValidationError where
+    mempty = NoVerifier
+    NoVerifier `mappend` e = e
+    e `mappend` NoVerifier = e
+    SigMismatch `mappend` _ = SigMismatch
+    _ `mappend` SigMismatch = SigMismatch
+    (ValidatorError e) `mappend` (ParseError _) = ValidatorError e
+    (ParseError _) `mappend` (ValidatorError e) = ValidatorError e
+
+
+verifySig :: Key -> Macaroon -> Either ValidationError Macaroon
+verifySig k m = bool (Left SigMismatch) (Right m) $
+    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 :: MonadIO m
+           => [Caveat -> m (Maybe (Either ValidationError Caveat))]
+           -> Macaroon
+           -> m (Either ValidationError Macaroon)
+verifyCavs verifiers m = gatherEithers <$> mapM validateCaveat (caveats m)
+  where
+    {-
+     - validateCaveat :: Caveat -> m (Validation String Caveat)
+     - We can use fromJust here safely since we use a `Just Failure` as a
+     - starting value for the foldM. We are guaranteed to have a `Just something`
+     - from it.
+     -}
+    validateCaveat c = fromJust <$> foldM (\res v -> mappend res . fmap eitherToValidation <$> v c) (defErr c) verifiers
+    -- defErr :: Caveat -> Maybe (Validation String Caveat)
+    defErr c = Just $ Failure NoVerifier
+    -- gatherEithers :: [Validation String Caveat] -> Either String Caveat
+    gatherEithers vs = case partitionEithers . map validationToEither $ vs of
+        ([],_) ->  Right m
+        (errs,_) -> Left (mconcat errs)