src/Crypto/Macaroon/Internal.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-|
   3 Module      : Crypto.Macaroon.Internal
   4 Copyright   : (c) 2015 Julien Tanguy
   5 License     : BSD3
   6
   7 Maintainer  : julien.tanguy@jhome.fr
   8 Stability   : experimental
   9 Portability : portable
  10
  11
  12 Internal representation of a macaroon
  13 -}
  14 module Crypto.Macaroon.Internal where
  15
  16
  17 import           Control.DeepSeq
  18 import           Crypto.Cipher.AES
  19 import           Crypto.Hash
  20 import           Data.Byteable
  21 import qualified Data.ByteString        as BS
  22 import qualified Data.ByteString.Base64 as B64
  23 import qualified Data.ByteString.Char8  as B8
  24 import           Data.Hex
  25 import           Data.List
  26
  27 -- |Type alias for Macaroons and Caveat keys and identifiers
  28 type Key = BS.ByteString
  29
  30 -- |Type alias for Macaroons and Caveat locations
  31 type Location = BS.ByteString
  32
  33 -- |Type alias for Macaroons signatures
  34 type Sig = BS.ByteString
  35
  36 -- | Main structure of a macaroon
  37 data Macaroon = MkMacaroon { location   :: Location
  38                            -- ^ Target location
  39                            , identifier :: Key
  40                            -- ^ Macaroon Identifier
  41                            , caveats    :: [Caveat]
  42                            -- ^ List of caveats
  43                            , signature  :: Sig
  44                            -- ^ Macaroon HMAC signature
  45                            }
  46
  47 instance Eq Macaroon where
  48     (MkMacaroon l1 i1 c1 s1) == (MkMacaroon l2 i2 c2 s2) =
  49         (l1 `constEqBytes` l2) &&!
  50         (i1 `constEqBytes` i2) &&!
  51         (c1 == c2) &&!
  52         (s1 `constEqBytes` s2)
  53
  54
  55 -- | show instance conforming to the @inspect@ "specification"
  56 instance Show Macaroon where
  57     -- We use intercalate because unlines would add a trailing newline
  58     show (MkMacaroon l i c s) = intercalate "\n" [
  59                       "location " ++ B8.unpack l
  60                     , "identifier " ++ B8.unpack i
  61                     , concatMap show c
  62                     , "signature " ++ B8.unpack (hex s)
  63                     ]
  64
  65 -- | NFData instance for use in the benchmark
  66 instance NFData Macaroon where
  67     rnf (MkMacaroon loc ident cavs sig) = rnf loc `seq` rnf ident `seq` rnf cavs `seq` rnf sig
  68
  69
  70 -- | Caveat structure
  71 data Caveat = MkCaveat { cid :: Key
  72                        -- ^ Caveat identifier
  73                        , vid :: Key
  74                        -- ^ Caveat verification key identifier
  75                        , cl  :: Location
  76                        -- ^ Caveat target location
  77                        }
  78
  79 instance Eq Caveat where
  80     (MkCaveat c1 v1 l1) == (MkCaveat c2 v2 l2) =
  81         (c1 `constEqBytes` c2) &&!
  82         (v1 `constEqBytes` v2) &&!
  83         (l1 `constEqBytes` l2)
  84
  85 -- | show instance conforming to the @inspect@ "specification"
  86 instance Show Caveat where
  87     show (MkCaveat c v l) | v == BS.empty = "cid " ++ B8.unpack c
  88                           | otherwise = unlines [ "cid " ++ B8.unpack c
  89                                                 , "vid " ++ B8.unpack v
  90                                                 , "cl " ++ B8.unpack l
  91                                                 ]
  92
  93
  94 -- | NFData instance for use in the benchmark
  95 instance NFData Caveat where
  96     rnf (MkCaveat cid vid cl) = rnf cid `seq` rnf vid `seq` rnf cl
  97
  98 -- | Primitive to add a First or Third party caveat to a macaroon
  99 -- For internal use only
 100 addCaveat :: Location
 101           -> Key
 102           -> Key
 103           -> Macaroon
 104           -> Macaroon
 105 addCaveat loc cid vid m = m { caveats = cavs ++ [cav'], signature = sig}
 106   where
 107     cavs = caveats m
 108     cav' = MkCaveat cid vid loc
 109     sig = toBytes (hmac (signature m) (BS.append vid cid) :: HMAC SHA256)
 110
 111 -- | Utility non-short circuiting '&&' function.
 112 (&&!) :: Bool -> Bool -> Bool
 113 True  &&! True  = True
 114 True  &&! False = False
 115 False &&! True  = False
 116 False &&! False = False
 117