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 -- | Constant-time Eq instance
  48 instance Eq Macaroon where
  49     (MkMacaroon l1 i1 c1 s1) == (MkMacaroon l2 i2 c2 s2) =
  50         (l1 `constEqBytes` l2) &&!
  51         (i1 `constEqBytes` i2) &&!
  52         (c1 == c2) &&!
  53         (s1 `constEqBytes` s2)
  54
  55
  56 -- | show instance conforming to the @inspect@ "specification"
  57 instance Show Macaroon where
  58     -- We use intercalate because unlines would add a trailing newline
  59     show (MkMacaroon l i c s) = intercalate "\n" [
  60                       "location " ++ B8.unpack l
  61                     , "identifier " ++ B8.unpack i
  62                     , concatMap show c
  63                     , "signature " ++ B8.unpack (hex s)
  64                     ]
  65
  66 -- | NFData instance for use in the benchmark
  67 instance NFData Macaroon where
  68     rnf (MkMacaroon loc ident cavs sig) = rnf loc `seq` rnf ident `seq` rnf cavs `seq` rnf sig
  69
  70
  71 -- | Caveat structure
  72 data Caveat = MkCaveat { cid :: Key
  73                        -- ^ Caveat identifier
  74                        , vid :: Key
  75                        -- ^ Caveat verification key identifier
  76                        , cl  :: Location
  77                        -- ^ Caveat target location
  78                        }
  79
  80 -- | Constant-time Eq instance
  81 instance Eq Caveat where
  82     (MkCaveat c1 v1 l1) == (MkCaveat c2 v2 l2) =
  83         (c1 `constEqBytes` c2) &&!
  84         (v1 `constEqBytes` v2) &&!
  85         (l1 `constEqBytes` l2)
  86
  87 -- | show instance conforming to the @inspect@ "specification"
  88 instance Show Caveat where
  89     show (MkCaveat c v l) | v == BS.empty = "cid " ++ B8.unpack c
  90                           | otherwise = unlines [ "cid " ++ B8.unpack c
  91                                                 , "vid " ++ B8.unpack v
  92                                                 , "cl " ++ B8.unpack l
  93                                                 ]
  94
  95
  96 -- | NFData instance for use in the benchmark
  97 instance NFData Caveat where
  98     rnf (MkCaveat cid vid cl) = rnf cid `seq` rnf vid `seq` rnf cl
  99
 100 -- | Primitive to add a First or Third party caveat to a macaroon
 101 -- For internal use only
 102 addCaveat :: Location
 103           -> Key
 104           -> Key
 105           -> Macaroon
 106           -> Macaroon
 107 addCaveat loc cid vid m = m { caveats = cavs ++ [cav'], signature = sig}
 108   where
 109     cavs = caveats m
 110     cav' = MkCaveat cid vid loc
 111     sig = toBytes (hmac (signature m) (BS.append vid cid) :: HMAC SHA256)
 112
 113 -- | Utility non-short circuiting '&&' function.
 114 (&&!) :: Bool -> Bool -> Bool
 115 True  &&! True  = True
 116 True  &&! False = False
 117 False &&! True  = False
 118 False &&! False = False
 119