3 files changed, 237 insertions, 0 deletions

diff --git a/src/Crypto/Macaroon.hs b/src/Crypto/Macaroon.hs
new file mode 100644
index 0000000..819a9eb
--- /dev/null
+++ b/src/Crypto/Macaroon.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-|
+Module      : Crypto.Macaroon
+Copyright   : (c) 2015 Julien Tanguy
+License     : BSD3
+
+Maintainer  : julien.tanguy@jhome.fr
+Stability   : experimental
+Portability : portable
+
+
+Pure haskell implementations of macaroons.
+
+Warning: this implementation has not been audited by security experts.
+Use it with caution.
+
+
+References:
+
+- Macaroons: Cookies with Contextual Caveats for Decentralized Authorization in the Cloud <http://research.google.com/pubs/pub41892.html>
+- Time for better security in NoSQL <http://hackingdistributed.com/2014/11/23/macaroons-in-hyperdex>
+
+-}
+module Crypto.Macaroon (
+    -- * Types
+      Macaroon
+    , Caveat
+    , Key
+    , Location
+    -- * Accessing functions
+    -- ** Macaroons
+    , location
+    , identifier
+    , caveats
+    , signature
+    -- ** Caveats
+    , caveatLoc
+    , caveatId
+    , caveatVId
+
+    -- * Create Macaroons
+    , create
+    , inspect
+    , addFirstPartyCaveat
+    , addThirdPartyCaveat
+
+    -- * Prepare Macaroons for transfer
+    , serialize
+    ) where
+
+import           Crypto.Cipher.AES
+import           Crypto.Hash
+import           Data.Byteable
+import qualified Data.ByteString            as BS
+import qualified Data.ByteString.Base64.URL as B64
+import qualified Data.ByteString.Char8      as B8
+import           Data.Hex
+
+import           Crypto.Macaroon.Internal
+
+-- | Create a Macaroon from its key, identifier and location
+create :: Key -> Key -> Location -> Macaroon
+create secret ident loc = MkMacaroon loc ident [] (toBytes (hmac derivedKey ident :: HMAC SHA256))
+  where
+    derivedKey = toBytes $ (hmac "macaroons-key-generator" secret :: HMAC SHA256)
+
+caveatLoc :: Caveat -> Location
+caveatLoc = cl
+
+caveatId :: Caveat -> Key
+caveatId = cid
+
+caveatVId :: Caveat -> Key
+caveatVId = vid
+
+inspect :: Macaroon -> String
+inspect m = unlines [ "location " ++ show (location m)
+                    , "identifier " ++ show (identifier m)
+                    , (concatMap (showCav (location m)) (caveats m))
+                    , "signature " ++ show (hex $ signature m)
+                    ]
+  where
+    showCav loc c | cl c == loc && vid c == BS.empty = "cid " ++ show (cid c)
+                  | otherwise = unlines [ "cid " ++ show (cid c)
+                                        , "vid " ++ show (vid c)
+                                        , "cl " ++ show (cl c)
+                                        ]
+
+serialize :: Macaroon -> BS.ByteString
+serialize m = B8.filter (/= '=') . B64.encode $ packets
+  where
+    packets = BS.concat [ putPacket "location" (location m)
+                        , putPacket "identifier" (identifier m)
+                        , caveatPackets
+                        , putPacket "signature" (signature m)
+                        ]
+    caveatPackets = BS.concat $ map (cavPacket (location m)) (caveats m)
+    cavPacket loc c | cl c == loc && vid c == BS.empty = putPacket "cid" (cid c)
+                    | otherwise = BS.concat [ putPacket "cid" (cid c)
+                                            , putPacket "vid" (vid c)
+                                            , putPacket "cl" (cl c)
+                                            ]
+
+
+
+-- | Add a first party Caveat to a Macaroon, with its identifier
+addFirstPartyCaveat :: Key -> Macaroon -> Macaroon
+addFirstPartyCaveat ident m = addCaveat (location m) ident BS.empty m
+
+-- |Add a third party Caveat to a Macaroon, using its location, identifier and
+-- verification key
+addThirdPartyCaveat :: Key
+                    -> Key
+                    -> Location
+                    -> Macaroon
+                    -> Macaroon
+addThirdPartyCaveat key cid loc m = addCaveat loc cid vid m
+  where
+    vid = encryptECB (initAES (signature m)) key
+
+
diff --git a/src/Crypto/Macaroon/Binder.hs b/src/Crypto/Macaroon/Binder.hs
new file mode 100644
index 0000000..3ec3d67
--- /dev/null
+++ b/src/Crypto/Macaroon/Binder.hs
@@ -0,0 +1,28 @@
+{-|
+Module      : Crypto.Macaroon.Binder
+Copyright   : (c) 2015 Julien Tanguy
+License     : BSD3
+
+Maintainer  : julien.tanguy@jhome.fr
+Stability   : experimental
+Portability : portable
+
+
+
+-}
+module Crypto.Macaroon.Binder where
+
+import           Crypto.Hash
+import           Data.Byteable
+import qualified Data.ByteString          as BS
+
+import           Crypto.Macaroon.Internal
+
+-- | Datatype for binding discharging and authorizing macaroons together
+newtype Binder = Binder { bind :: Macaroon -> Macaroon -> BS.ByteString }
+
+
+-- | Binder which concatenates the two signatures and hashes them
+hashSigs :: Binder
+hashSigs = Binder $ \m m' -> toBytes $ (HMAC . hash $ BS.append (toBytes $ signature m') (toBytes $ signature m) :: HMAC SHA256)
+
diff --git a/src/Crypto/Macaroon/Internal.hs b/src/Crypto/Macaroon/Internal.hs
new file mode 100644
index 0000000..fc50486
--- /dev/null
+++ b/src/Crypto/Macaroon/Internal.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-|
+Module      : Crypto.Macaroon.Internal
+Copyright   : (c) 2015 Julien Tanguy
+License     : BSD3
+
+Maintainer  : julien.tanguy@jhome.fr
+Stability   : experimental
+Portability : portable
+
+
+Internal representation of a macaroon
+-}
+module Crypto.Macaroon.Internal where
+
+
+import           Control.DeepSeq
+import           Crypto.Cipher.AES
+import           Crypto.Hash
+import           Data.Byteable
+import qualified Data.ByteString        as BS
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8  as B8
+import           Data.Char
+import           Data.Hex
+import           Data.Serialize
+import           Data.Word
+
+-- |Type alias for Macaroons and Caveat keys and identifiers
+type Key = BS.ByteString
+
+-- |Type alias For Macaroons and Caveat locations
+type Location = BS.ByteString
+
+type Sig = BS.ByteString
+
+-- | Main structure of a macaroon
+data Macaroon = MkMacaroon { location   :: Location
+                           -- ^ Target location
+                           , identifier :: Key
+                           -- ^ Macaroon Identifier
+                           , caveats    :: [Caveat]
+                           -- ^ List of caveats
+                           , signature  :: Sig
+                           -- ^ Macaroon HMAC signature
+                           } deriving (Eq)
+
+
+instance NFData Macaroon where
+    rnf (MkMacaroon loc ident cavs sig) = rnf loc `seq` rnf ident `seq` rnf cavs `seq` rnf sig
+
+
+-- | Caveat structure
+data Caveat = MkCaveat { cid :: Key
+                       -- ^ Caveat identifier
+                       , vid :: Key
+                       -- ^ Caveat verification key identifier
+                       , cl  :: Location
+                       -- ^ Caveat target location
+
+                       } deriving (Eq)
+
+instance NFData Caveat where
+    rnf (MkCaveat cid vid cl) = rnf cid `seq` rnf vid `seq` rnf cl
+
+
+putPacket :: BS.ByteString -> BS.ByteString -> BS.ByteString
+putPacket key dat = BS.concat [
+    B8.map toLower . hex . encode $ (fromIntegral size :: Word16)
+    , key
+    , " "
+    , dat
+    , "\n"
+    ]
+  where
+    size = 4 + 2 + BS.length key + BS.length dat
+
+addCaveat :: Location
+          -> Key
+          -> Key
+          -> Macaroon
+          -> Macaroon
+addCaveat loc cid vid m = m { caveats = cavs ++ [cav'], signature = sig}
+  where
+    cavs = caveats m
+    cav' = MkCaveat cid vid loc
+    sig = toBytes $ (hmac (signature m) (BS.append vid cid) :: HMAC SHA256)
+