├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── bench.hs ├── doc └── notes.md ├── hmacaroons.cabal ├── scripts └── pushdoc.sh ├── src └── Crypto │ ├── Macaroon.hs │ └── Macaroon │ ├── Binder.hs │ ├── Internal.hs │ ├── Serializer │ └── Base64.hs │ ├── Verifier.hs │ └── Verifier │ └── Internal.hs ├── stack.yaml └── test ├── Crypto └── Macaroon │ ├── Instances.hs │ ├── Serializer │ └── Base64 │ │ └── Tests.hs │ ├── Tests.hs │ └── Verifier │ ├── Internal │ └── Tests.hs │ └── Tests.hs ├── Sanity.hs └── main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | .stack-work 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Configuration copied from docs.haskellstack.org 2 | sudo: false 3 | language: generic 4 | # Caching so the next build will be fast too. 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | notifications: 10 | webhooks: 11 | urls: 12 | - https://webhooks.gitter.im/e/5dfabef9855765e0c386 13 | on_success: change 14 | on_failure: always 15 | on_start: never 16 | 17 | env: 18 | global: 19 | - GH_REF: github.com/jtanguy/hmacaroons.git 20 | - secure: "cpcJvp233pVNy05VeWgzUEw1xYCekk1xT1x2grzhUx8mpCqXZda+Xbu76QCqLSESPgc8Q39m6bR8c+oLkbgRM1U+hR91+2sccKaP9cLTad0yoPRdm6qDB96mzLcEX+yl22GVVzSg20AZx0B9edIT9z7pnEVMJV4iDwhsx/p5Uas=" 21 | 22 | matrix: 23 | include: 24 | - env: RESOLVER=lts-11.17 PUSH_DOCS=true 25 | compiler: ": #stack 8.2.2" 26 | - env: RESOLVER=lts-12.0 PUSH_DOCS=false 27 | compiler: ": #stack 8.4.3" 28 | - env: RESOLVER=nightly PUSH_DOCS=false 29 | compiler: ": #stack nightly" 30 | allow_failures: 31 | - env: RESOLVER=nightly 32 | 33 | 34 | before_install: 35 | - unset CC 36 | # Download and unpack the stack executable 37 | - mkdir -p ~/.local/bin 38 | - export PATH=$HOME/.local/bin:$PATH 39 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 40 | 41 | install: 42 | # Build the dependencies 43 | - stack --no-terminal --install-ghc --resolver $RESOLVER test --bench --only-dependencies 44 | #- stack --no-terminal --resolver $RESOLVER install stack-hpc-coveralls 45 | 46 | script: 47 | - stack --no-terminal --resolver $RESOLVER test --coverage 48 | - stack --no-terminal --resolver $RESOLVER bench 49 | # - shc hmacaroons test 50 | 51 | after_script: 52 | - if [ true = $PUSH_DOCS ]; then bash ./scripts/pushdoc.sh; fi 53 | # EOF 54 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for [hmacaroons](https://github.com/jtanguy/hmacaroons) 2 | 3 | ## 0.1.0 -- (Current development version) 4 | 5 | * Macaroon creation 6 | * Base64 serialization 7 | * First party caveats 8 | - Basic signature verification 9 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | How to contribute 2 | ================= 3 | First and most important: Submit issues ! 4 | 5 | If you want to contribute, please fork the repo, and send us a pull request with 6 | your changes. 7 | 8 | Tests and cabal flags 9 | --------------------- 10 | For this project we use the standard hunit/quickcheck tests. 11 | If you want to submit a new feature, please try to integrate at least 12 | *some* tests. 13 | 14 | Code style 15 | ---------- 16 | We do not impose any specific style of code, but you can improve your code 17 | by running it through `hlint`. 18 | 19 | Crypto analysis 20 | --------------- 21 | This library has **not** been audited by security experts ! 22 | It relies on an existing implementation and crypto libraries. 23 | 24 | Any analysis is welcome, and I will gladly merge it. 25 | 26 | 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Julien Tanguy 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julien Tanguy nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Macaroons: Pure haskell implementation of macaroons 2 | =================================================== 3 | 4 | ![Maintenance Status](https://img.shields.io/badge/maintenance%20status-needs%20love-ff69b4.svg) 5 | [![Build Status](https://travis-ci.org/jtanguy/hmacaroons.svg?branch=master)](https://travis-ci.org/jtanguy/hmacaroons) 6 | [![Coverage Status](https://coveralls.io/repos/github/jtanguy/hmacaroons/badge.svg?branch=master)](https://coveralls.io/github/jtanguy/hmacaroons?branch=master) 7 | [![Join the chat at https://gitter.im/jtanguy/hmacaroons](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/jtanguy/hmacaroons?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 8 | 9 | Macaroons is a pure haskell implementation of macaroons. It aims to provide 10 | compatibility at a serialized level with the [reference implementation](https://github.com/rescrv/libmacaroons) 11 | and the [python implementation](https://github.com/ecordell/pymacaroons) 12 | 13 | **WARNING: This library has not been audited by security experts.** 14 | **There is no error handling at the moment, everyhting is silently accepted** 15 | 16 | It is developed in the purpose of exploration purposes, and would need much 17 | more attention if it were to be used in production. 18 | 19 | References 20 | ========== 21 | 22 | Papers and articles 23 | ------------------- 24 | 25 | - [Google paper on macaroons](http://research.google.com/pubs/pub41892.html) 26 | - [Macaroons at Mozilla](https://air.mozilla.org/macaroons-cookies-with-contextual-caveats-for-decentralized-authorization-in-the-cloud/) 27 | - [Time for better security in NoSQL](http://hackingdistributed.com/2014/11/23/macaroons-in-hyperdex/) 28 | 29 | Implementations 30 | --------------- 31 | 32 | - [C](https://github.com/rescrv/libmacaroons) 33 | - [Java](https://github.com/nitram509/jmacaroons) 34 | - [Node.js](https://github.com/nitram509/macaroons.js) 35 | - [Python](https://github.com/ecordell/pymacaroons) 36 | - [Rust](https://github.com/cryptosphere/rust-macaroons.git) 37 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/bench.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.ByteString (ByteString) 4 | import Criterion.Main 5 | 6 | import Crypto.Macaroon 7 | import Crypto.Macaroon.Internal 8 | 9 | 10 | loc :: ByteString 11 | loc = "http://mybank/" 12 | 13 | ident :: ByteString 14 | ident = "we used our secret key" 15 | 16 | key :: ByteString 17 | key = "this is our super secret key; only we should know it" 18 | 19 | cav :: ByteString 20 | cav = "test = caveat" 21 | 22 | 23 | {-#INLINE benchCreate#-} 24 | benchCreate :: (Key, Key, Location) -> Macaroon 25 | benchCreate (secret, ident, loc) = create secret ident loc 26 | 27 | {-#INLINE benchMint #-} 28 | benchMint :: ((Key, Key, Location), ByteString) -> Macaroon 29 | benchMint (ms,c) = addFirstPartyCaveat c (benchCreate ms) 30 | 31 | main = defaultMain [ 32 | bgroup "Crypto.Macaroon" [ bench "create" $ nf benchCreate (key,ident,loc) 33 | , bench "mint" $ nf benchMint ((key,ident,loc),cav) 34 | ] 35 | ] 36 | -------------------------------------------------------------------------------- /doc/notes.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Notes on macaroons and their implementation in haskell 3 | author: Julien Tanguy 4 | date: 2015-05-13 5 | --- 6 | 7 | Macaroons are not better than readily available SPKI/SDSI 8 | 9 | They provide a framework for any token-based credential systems in the cloud 10 | 11 | Examples: 12 | - Cookies 13 | - OAuth tokens 14 | - SAML/OpenID assertions 15 | - unlisted URLs 16 | 17 | Macaroons support: 18 | 19 | - attenuation 20 | - delegation 21 | - contextual confinement 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /hmacaroons.cabal: -------------------------------------------------------------------------------- 1 | name: hmacaroons 2 | version: 0.5.0.0 3 | synopsis: Haskell implementation of macaroons 4 | description: 5 | Hmacaroons is a pure haskell implementation of macaroons. It aims to 6 | provide compatibility at a serialized level with the 7 | and 8 | the 9 | . 10 | __WARNING: This library has not been audited by security experts.__ 11 | __There is no error handling at the moment, everything is silently accepted__ 12 | . 13 | It is developed in the purpose of exploration purposes, and would need 14 | much more attention if it were to be used in production. 15 | . 16 | = References 17 | #references# 18 | . 19 | == Papers and articles 20 | #papers-and-articles# 21 | . 22 | - 23 | - 24 | - 25 | . 26 | == Implementations 27 | #implementations# 28 | . 29 | - 30 | - 31 | - 32 | - 33 | - 34 | license: BSD3 35 | license-file: LICENSE 36 | author: Julien Tanguy 37 | maintainer: julien.tanguy@jhome.fr 38 | homepage: https://github.com/jtanguy/hmacaroons 39 | bug-reports: https://github.com/jtanguy/hmacaroons/issues 40 | category: Data 41 | build-type: Simple 42 | extra-source-files: README.md 43 | CONTRIBUTING.md 44 | CHANGELOG.md 45 | cabal-version: >=1.10 46 | tested-with: GHC==7.8.4, GHC==7.10.1 47 | 48 | source-repository head 49 | type: git 50 | branch: master 51 | location: https://github.com/jtanguy/hmacaroons 52 | 53 | library 54 | exposed-modules: Crypto.Macaroon 55 | -- Crypto.Macaroon.Binder 56 | Crypto.Macaroon.Serializer.Base64 57 | Crypto.Macaroon.Verifier 58 | other-modules: Crypto.Macaroon.Internal 59 | Crypto.Macaroon.Verifier.Internal 60 | ghc-options: -fwarn-unused-imports 61 | build-depends: base >=4 && < 5, 62 | attoparsec >=0.12, 63 | transformers >= 0.3, 64 | bytestring >=0.10, 65 | base64-bytestring >= 1.0, 66 | byteable >= 0.1 && <0.2, 67 | cereal >= 0.4, 68 | cryptohash >=0.11 && <0.12, 69 | either >=4.4, 70 | -- nonce, 71 | -- cipher-aes >=0.2 && <0.3, 72 | deepseq >= 1.1, 73 | hex >= 0.2.0 74 | hs-source-dirs: src 75 | default-language: Haskell2010 76 | 77 | benchmark bench 78 | default-language: Haskell2010 79 | type: exitcode-stdio-1.0 80 | hs-source-dirs: src, bench 81 | main-is: bench.hs 82 | ghc-options: -O2 83 | build-depends: base >= 4 && <5, 84 | attoparsec >=0.12, 85 | bytestring >=0.10, 86 | base64-bytestring >= 1.0, 87 | byteable >= 0.1 && <0.2, 88 | cereal >= 0.4, 89 | cryptohash >=0.11 && <0.12, 90 | transformers >= 0.3, 91 | -- cipher-aes >=0.2 && <0.3, 92 | either >=4.4, 93 | hex >= 0.2.0, 94 | deepseq >= 1.1, 95 | criterion >= 1.1 96 | 97 | test-suite test 98 | default-language: Haskell2010 99 | type: exitcode-stdio-1.0 100 | hs-source-dirs: src, test 101 | main-is: main.hs 102 | build-depends: base >= 4 && <5, 103 | attoparsec >=0.12, 104 | bytestring >=0.10, 105 | base64-bytestring >= 1.0, 106 | byteable >= 0.1 && <0.2, 107 | cereal >= 0.4, 108 | cryptohash >=0.11 && <0.12, 109 | either >=4.4, 110 | hex >= 0.2.0, 111 | tasty >= 0.10, 112 | tasty-hunit >= 0.9, 113 | tasty-quickcheck >= 0.8, 114 | QuickCheck >= 2.8, 115 | deepseq >= 1.1, 116 | transformers >= 0.3 117 | -------------------------------------------------------------------------------- /scripts/pushdoc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e # exit with nonzero exit code if anything fails 3 | 4 | DIST=$(stack --no-terminal --resolver $RESOLVER path --dist-dir) 5 | 6 | # Build documentation 7 | stack --no-terminal --resolver $RESOLVER haddock --no-haddock-deps 8 | 9 | # Copy benchmark 10 | cp benchmark.html "$DIST/doc/html/hmacaroons" 11 | 12 | # Go to haddock output dir 13 | cd "$DIST/doc/html/hmacaroons" 14 | 15 | # Quiet the git init message, since it's not useful in the build log 16 | git init > /dev/null 2>&1 17 | 18 | # inside this git repo we'll pretend to be a new user 19 | git config user.name "Travis CI" 20 | git config user.email "julien.tanguy@jhome.fr" 21 | 22 | # The first and only commit to this new Git repo contains all the 23 | # files present with the commit message "Deploy to GitHub Pages". 24 | git add . 25 | # Silence the commit too 26 | git commit -m "Deploy to GitHub Pages" > /dev/null 2>&1 27 | 28 | 29 | # Force push from the current repo's master branch to the remote 30 | # repo's gh-pages branch. (All previous history on the gh-pages branch 31 | # will be lost, since we are overwriting it.) We redirect any output to 32 | # /dev/null to hide any sensitive credential data that might otherwise be exposed. 33 | echo "Pushing haddock to gh-pages" 34 | git push --force --quiet "https://${GH_TOKEN}@${GH_REF}" master:gh-pages > /dev/null 2>&1 35 | 36 | cd ~/build/jtanguy/hmacaroons 37 | -------------------------------------------------------------------------------- /src/Crypto/Macaroon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Module : Crypto.Macaroon 4 | Copyright : (c) 2015 Julien Tanguy 5 | License : BSD3 6 | 7 | Maintainer : julien.tanguy@jhome.fr 8 | Stability : experimental 9 | Portability : portable 10 | 11 | Pure haskell implementations of macaroons. 12 | 13 | Warning: this implementation has not been audited by security experts. 14 | Do not use in production 15 | 16 | 17 | References: 18 | 19 | - Macaroons: Cookies with Contextual Caveats for Decentralized Authorization in the Cloud 20 | - Time for better security in NoSQL 21 | -} 22 | module Crypto.Macaroon ( 23 | -- * Types 24 | Macaroon 25 | , Caveat 26 | , Secret 27 | , Key 28 | , Location 29 | , Sig 30 | -- * Accessing functions 31 | -- ** Macaroons 32 | , location 33 | , identifier 34 | , caveats 35 | , signature 36 | -- ** Caveats 37 | , cl 38 | , cid 39 | , vid 40 | 41 | -- * Create Macaroons 42 | , create 43 | , inspect 44 | , addFirstPartyCaveat 45 | -- , addThirdPartyCaveat 46 | -- * Serialize 47 | , module Crypto.Macaroon.Serializer.Base64 48 | -- * Verify 49 | , module Crypto.Macaroon.Verifier 50 | ) where 51 | 52 | -- import Crypto.Cipher.AES 53 | import Crypto.Hash 54 | import Data.Byteable 55 | import qualified Data.ByteString as BS 56 | 57 | import Crypto.Macaroon.Internal 58 | import Crypto.Macaroon.Serializer.Base64 59 | import Crypto.Macaroon.Verifier 60 | 61 | -- | Create a Macaroon from its key, identifier and location 62 | create :: Secret -> Key -> Location -> Macaroon 63 | create secret ident loc = MkMacaroon loc ident [] (toBytes (hmac derivedKey ident :: HMAC SHA256)) 64 | where 65 | derivedKey = toBytes (hmac "macaroons-key-generator" secret :: HMAC SHA256) 66 | 67 | -- | Inspect a macaroon's contents. For debugging purposes. 68 | inspect :: Macaroon -> String 69 | inspect = show 70 | 71 | -- | Add a first party Caveat to a Macaroon, with its identifier 72 | addFirstPartyCaveat :: Key -> Macaroon -> Macaroon 73 | addFirstPartyCaveat ident m = addCaveat (location m) ident BS.empty m 74 | 75 | -- |Add a third party Caveat to a Macaroon, using its location, identifier and 76 | -- verification key 77 | -- addThirdPartyCaveat :: Key 78 | -- -> Key 79 | -- -> Location 80 | -- -> Macaroon 81 | -- -> Macaroon 82 | -- addThirdPartyCaveat key cid loc m = addCaveat loc cid vid m 83 | -- where 84 | -- vid = encryptECB (initAES (signature m)) key 85 | -------------------------------------------------------------------------------- /src/Crypto/Macaroon/Binder.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Crypto.Macaroon.Binder 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | Stability : experimental 8 | Portability : portable 9 | 10 | 11 | 12 | -} 13 | module Crypto.Macaroon.Binder where 14 | 15 | import Crypto.Hash 16 | import Data.Byteable 17 | import qualified Data.ByteString as BS 18 | 19 | import Crypto.Macaroon.Internal 20 | 21 | -- | Datatype for binding discharging and authorizing macaroons together 22 | newtype Binder = Binder { bind :: Macaroon -> Macaroon -> BS.ByteString } 23 | 24 | 25 | -- | Binder which concatenates the two signatures and hashes them 26 | hashSigs :: Binder 27 | hashSigs = Binder $ \m m' -> toBytes (HMAC . hash $ BS.append (toBytes $ signature m') (toBytes $ signature m) :: HMAC SHA256) 28 | 29 | -------------------------------------------------------------------------------- /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.Hash 19 | import Data.Byteable 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Char8 as B8 22 | import Data.Hex 23 | import Data.List 24 | 25 | 26 | -- |Type alias for Macaroons secret keys 27 | type Secret = BS.ByteString 28 | 29 | -- |Type alias for Macaroons and Caveat and identifiers 30 | type Key = BS.ByteString 31 | 32 | -- |Type alias for Macaroons and Caveat locations 33 | type Location = BS.ByteString 34 | 35 | -- |Type alias for Macaroons signatures 36 | type Sig = BS.ByteString 37 | 38 | -- | Main structure of a macaroon 39 | data Macaroon = MkMacaroon { location :: Location 40 | -- ^ Target location 41 | , identifier :: Key 42 | -- ^ Macaroon Identifier 43 | , caveats :: [Caveat] 44 | -- ^ List of caveats 45 | , signature :: Sig 46 | -- ^ Macaroon HMAC signature 47 | } 48 | 49 | -- | Constant-time Eq instance 50 | instance Eq Macaroon where 51 | (MkMacaroon l1 i1 c1 s1) == (MkMacaroon l2 i2 c2 s2) = 52 | (l1 `constEqBytes` l2) &&! 53 | (i1 `constEqBytes` i2) &&! 54 | (c1 == c2) &&! 55 | (s1 `constEqBytes` s2) 56 | 57 | 58 | -- | show instance conforming to the @inspect@ "specification" 59 | instance Show Macaroon where 60 | -- We use intercalate because unlines would add a trailing newline 61 | show (MkMacaroon l i c s) = intercalate "\n" [ 62 | "location " ++ B8.unpack l 63 | , "identifier " ++ B8.unpack i 64 | , intercalate "\n" (map show c) 65 | , "signature " ++ B8.unpack (hex s) 66 | ] 67 | 68 | -- | NFData instance for use in the benchmark 69 | instance NFData Macaroon where 70 | rnf (MkMacaroon loc ident cavs sig) = rnf loc `seq` rnf ident `seq` rnf cavs `seq` rnf sig 71 | 72 | 73 | -- | Caveat structure 74 | data Caveat = MkCaveat { cid :: Key 75 | -- ^ Caveat identifier 76 | , vid :: Key 77 | -- ^ Caveat verification key identifier 78 | , cl :: Location 79 | -- ^ Caveat target location 80 | } 81 | 82 | -- | Constant-time Eq instance 83 | instance Eq Caveat where 84 | (MkCaveat c1 v1 l1) == (MkCaveat c2 v2 l2) = 85 | (c1 `constEqBytes` c2) &&! 86 | (v1 `constEqBytes` v2) &&! 87 | (l1 `constEqBytes` l2) 88 | 89 | -- | show instance conforming to the @inspect@ "specification" 90 | instance Show Caveat where 91 | show (MkCaveat c v l) | v == BS.empty = "cid " ++ B8.unpack c 92 | | otherwise = unlines [ "cid " ++ B8.unpack c 93 | , "vid " ++ B8.unpack v 94 | , "cl " ++ B8.unpack l 95 | ] 96 | 97 | 98 | -- | NFData instance for use in the benchmark 99 | instance NFData Caveat where 100 | rnf (MkCaveat cid vid cl) = rnf cid `seq` rnf vid `seq` rnf cl 101 | 102 | -- | Primitive to add a First or Third party caveat to a macaroon 103 | -- For internal use only 104 | addCaveat :: Location 105 | -> Key 106 | -> Key 107 | -> Macaroon 108 | -> Macaroon 109 | addCaveat loc cid vid m = m { caveats = cavs ++ [cav'], signature = sig} 110 | where 111 | cavs = caveats m 112 | cav' = MkCaveat cid vid loc 113 | sig = toBytes (hmac (signature m) (BS.append vid cid) :: HMAC SHA256) 114 | 115 | -- | Utility non-short circuiting '&&' function. 116 | (&&!) :: Bool -> Bool -> Bool 117 | True &&! True = True 118 | True &&! False = False 119 | False &&! True = False 120 | False &&! False = False 121 | 122 | -------------------------------------------------------------------------------- /src/Crypto/Macaroon/Serializer/Base64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Module : Crypto.Macaroon.Serializer.Base64 4 | Copyright : (c) 2015 Julien Tanguy 5 | License : BSD3 6 | 7 | Maintainer : julien.tanguy@jhome.fr 8 | Stability : experimental 9 | Portability : portable 10 | 11 | Base64 serializer/deserializer 12 | 13 | -} 14 | module Crypto.Macaroon.Serializer.Base64 ( 15 | serialize 16 | , deserialize 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Monad 21 | import Crypto.Macaroon.Internal 22 | import Data.Attoparsec.ByteString 23 | import qualified Data.Attoparsec.ByteString.Char8 as A8 24 | import qualified Data.ByteString as BS 25 | import qualified Data.ByteString.Base64.URL as B64 26 | import qualified Data.ByteString.Char8 as B8 27 | import Data.Char 28 | import Data.Hex 29 | import Data.List 30 | import Data.Serialize 31 | import Data.Word 32 | 33 | 34 | -- | Serialize a macaroon in an URL-safe Base64 encoding 35 | serialize :: Macaroon -> BS.ByteString 36 | serialize m = B8.filter (/= '=') . B64.encode . runPut $ do 37 | packetize "location" (location m) 38 | packetize "identifier" (identifier m) 39 | forM_ (caveats m) $ \c -> do 40 | packetize "cid" (cid c) 41 | unless (cl c == location m && vid c == BS.empty) $ do 42 | packetize "vid" (vid c) 43 | packetize "cl" (cl c) 44 | packetize "signature" (signature m) 45 | 46 | packetize :: BS.ByteString -> BS.ByteString -> Put 47 | packetize key dat = do 48 | let size = 4 + 2 + BS.length key + BS.length dat 49 | putByteString $ B8.map toLower . hex . encode $ (fromIntegral size :: Word16) 50 | putByteString key 51 | putByteString " " 52 | putByteString dat 53 | putByteString "\n" 54 | 55 | -- | Deserialize a macaroon from a base64url-encoded ByteString 56 | deserialize :: BS.ByteString -> Either String Macaroon 57 | deserialize = parseOnly macaroon . B64.decodeLenient 58 | 59 | 60 | macaroon :: Parser Macaroon 61 | macaroon = do 62 | ps <- many packet <* endOfInput 63 | let (header,ps') = splitAt 2 ps 64 | (l, i) <- case header of 65 | [("location",l),("identifier",i)] -> pure (l, i) 66 | _ -> fail "missing macaroon header" 67 | let (caveats,sig) = splitAt (length ps' - 1) ps' 68 | s <- case sig of 69 | [("signature", s)] -> pure s 70 | _ -> fail "missing macaroon signature" 71 | return $ MkMacaroon l i (map (mkCaveat l) (groupBy splitCavs caveats)) s 72 | where 73 | mkCaveat _ [("cid",c),("vid",v),("cl",l)] = MkCaveat c v l 74 | mkCaveat l [("cid",c)] = MkCaveat c BS.empty l 75 | mkCaveat _ _ = error "Malformed caveat" 76 | splitCavs _ ("cid",_) = False 77 | splitCavs _ _ = True 78 | 79 | packet :: Parser (BS.ByteString, BS.ByteString) 80 | packet = do 81 | size <- A8.take 4 82 | case A8.parseOnly (A8.hexadecimal :: Parser Word16) size of 83 | Left e -> fail e 84 | Right s -> do 85 | bs <- A8.take (fromIntegral $ s - 4) 86 | let (key, dat) = B8.break (== ' ') bs 87 | return (key, B8.tail $ B8.init dat) 88 | 89 | -------------------------------------------------------------------------------- /src/Crypto/Macaroon/Verifier.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Crypto.Macaroon.Verifier 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | Stability : experimental 8 | Portability : portable 9 | 10 | 11 | 12 | -} 13 | module Crypto.Macaroon.Verifier ( 14 | verify 15 | , verifySync 16 | , VerifierResult(..) 17 | , VerifierError(..) 18 | , ValidationError(..) 19 | ) where 20 | 21 | 22 | import Data.Functor.Identity 23 | 24 | import Crypto.Macaroon.Internal 25 | import Crypto.Macaroon.Verifier.Internal 26 | 27 | 28 | 29 | -- | Verify a Macaroon's signature and caveats, given the corresponding Secret 30 | -- and verifiers. 31 | -- 32 | -- A verifier is a function of type 33 | -- @'Monad' m => 'Caveat' -> m VerifierResult@. 34 | -- 35 | -- It should return: 36 | -- 37 | -- * 'Unrelated' if the caveat is not related to the verifier 38 | -- (for instance a time verifier is given an action caveat); 39 | -- * 'Refused' ('ParseError' reason) if the verifier is related to the 40 | -- caveat, but failed to parse it completely; 41 | -- * 'Refused' ('VerifierError' reason) if the verifier is related to the 42 | -- caveat, parsed it and invalidated it; 43 | -- * 'Verified' if the verifier has successfully verified the 44 | -- given caveat 45 | verify :: (Applicative m) 46 | => Secret 47 | -> [Caveat 48 | -> m (VerifierResult pe ve)] 49 | -> Macaroon 50 | -> m (Either (ValidationError pe ve) Macaroon) 51 | verify secret verifiers m = 52 | let checkSig = verifySig secret 53 | checkCavs = fmap (fmap $ const m) . either (pure . Left) (verifyCavs verifiers . caveats ) 54 | in checkCavs . checkSig $ m 55 | 56 | -- | Synchronously verify a macaroon signature and caveats, given the 57 | -- corresponding Secret and verifiers. 58 | -- This is a variant of @verify@ working with synchronous verifiers. 59 | verifySync :: Secret -> [Caveat -> VerifierResult pe ve] -> Macaroon -> Either (ValidationError pe ve) Macaroon 60 | verifySync secret verifiers m = 61 | let verifiersIdent = fmap (fmap Identity) verifiers 62 | in runIdentity $ verify secret verifiersIdent m 63 | -------------------------------------------------------------------------------- /src/Crypto/Macaroon/Verifier/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-| 6 | Module : Crypto.Macaroon.Verifier.Internal 7 | Copyright : (c) 2015 Julien Tanguy 8 | License : BSD3 9 | 10 | Maintainer : julien.tanguy@jhome.fr 11 | Stability : experimental 12 | Portability : portable 13 | 14 | 15 | 16 | -} 17 | module Crypto.Macaroon.Verifier.Internal where 18 | 19 | import Control.Arrow ((&&&)) 20 | import Crypto.Hash 21 | import Data.Bool 22 | import Data.Byteable 23 | import qualified Data.ByteString as BS 24 | import Data.Foldable 25 | import Data.List.NonEmpty (NonEmpty, nonEmpty) 26 | import Data.Maybe 27 | 28 | import Crypto.Macaroon.Internal 29 | 30 | 31 | -- | Type representing the result of a validator 32 | data VerifierResult pe ve = Verified -- ^ The caveat is correctly parsed and verified 33 | | Refused (VerifierError pe ve) -- ^ The caveat is refused 34 | | Unrelated -- ^ The given verifier does not verify the caveat 35 | 36 | deriving instance (Show pe, Show ve) => Show (VerifierResult pe ve) 37 | deriving instance (Eq pe, Eq ve) => Eq (VerifierResult pe ve) 38 | 39 | -- | Type representing an error returned by a verifier (on a caveat it's supposed to handle) 40 | data VerifierError pe ve = ParseError pe -- ^ The caveat couldn't be parsed 41 | | VerifierError ve -- ^ The verifier understood the caveat but couldn't satisfy it. 42 | 43 | deriving instance (Show pe, Show ve) => Show (VerifierError pe ve) 44 | deriving instance (Eq pe, Eq ve) => Eq (VerifierError pe ve) 45 | 46 | -- | Type alias for a caveat that was not discharged 47 | -- an empty list means that no verifiers were related to the caveat 48 | type RemainingCaveat pe ve = (Caveat, [VerifierError pe ve]) 49 | 50 | -- | Type representing a macaroon validation error. 51 | data ValidationError pe ve = SigMismatch -- ^ Signatures do not match 52 | | RemainingCaveats (NonEmpty (RemainingCaveat pe ve)) 53 | -- ^ There are remaining caveats 54 | -- 55 | deriving instance (Show pe, Show ve) => Show (ValidationError pe ve) 56 | deriving instance (Eq pe, Eq ve) => Eq (ValidationError pe ve) 57 | 58 | -- | Check that the given macaroon has a correct signature 59 | verifySig :: Key -> Macaroon -> Either (ValidationError pe ve) Macaroon 60 | verifySig k m = bool (Left SigMismatch) (Right m) $ 61 | signature m == foldl' hash (toBytes (hmac derivedKey (identifier m) :: HMAC SHA256)) (caveats m) 62 | where 63 | hash s c = toBytes (hmac s (vid c `BS.append` cid c) :: HMAC SHA256) 64 | derivedKey = toBytes (hmac "macaroons-key-generator" k :: HMAC SHA256) 65 | 66 | -- | Given a list of verifiers, verify each caveat of the given 67 | -- list. You shouldn't use it directly unless you're doing fancy multi-step validation 68 | verifyCavs :: forall m pe ve. (Applicative m) 69 | => [Caveat -> m (VerifierResult pe ve)] 70 | -> [Caveat] 71 | -> m (Either (ValidationError pe ve) ()) 72 | verifyCavs verifiers caveats = toEither <$> errors 73 | where 74 | toEither = maybe (Right ()) (Left . RemainingCaveats) . nonEmpty 75 | errors = catMaybes <$> traverse keepErrors caveats 76 | 77 | -- apply the verifiers to a caveat and only keep errors 78 | keepErrors :: Caveat -> m (Maybe (RemainingCaveat pe ve)) 79 | keepErrors = 80 | fmap sequenceA . -- Move the Maybe outside the tuple 81 | sequenceA . -- Move the m outside the tuple 82 | getTaggedErrors 83 | 84 | -- annotated results 85 | getTaggedErrors :: Caveat -> (Caveat, m (Maybe [VerifierError pe ve])) 86 | getTaggedErrors = id &&& fmap collapseErrors . applyVerifiers 87 | 88 | -- collapse all the results, @Nothing@ means the caveat has been 89 | -- verified 90 | collapseErrors :: [VerifierResult pe ve] -> Maybe [VerifierError pe ve] 91 | collapseErrors rs = 92 | -- using `elem` would require an @Eq@ constraint on pe and ve 93 | if any isVerified rs 94 | then Nothing 95 | else Just [e | Refused e <- rs] 96 | isVerified Verified = True 97 | isVerified _ = False 98 | 99 | -- apply all the verifiers to a caveat. 100 | applyVerifiers :: Caveat -> m [VerifierResult pe ve] 101 | applyVerifiers c = traverse ($ c) verifiers 102 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-16.31 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | extra-deps: 42 | - git: https://github.com/taruti/haskell-hex 43 | commit: 5953ae445ae8f608858903280fe3d9d2b503ae31 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.7" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /test/Crypto/Macaroon/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | 8 | 9 | This test suite is based on the pymacaroons test suite: 10 | 11 | -} 12 | module Crypto.Macaroon.Instances where 13 | 14 | import qualified Data.ByteString as BS 15 | import qualified Data.ByteString.Char8 as B8 16 | import Data.List 17 | import Test.Tasty.QuickCheck 18 | 19 | import Crypto.Macaroon 20 | 21 | newtype Url = Url { unUrl :: BS.ByteString } deriving (Show) 22 | 23 | instance Arbitrary Url where 24 | arbitrary = do 25 | protocol <- elements ["http://"] 26 | name <- fmap (intercalate ".") <$> listOf1 . listOf1 $ elements ['a'..'z'] 27 | domain <- elements [".com",".net"] 28 | return . Url . B8.pack $ (protocol ++ name ++ domain) 29 | 30 | newtype BSSecret = BSSecret { unSecret :: BS.ByteString } deriving (Show) 31 | 32 | instance Arbitrary BSSecret where 33 | arbitrary = BSSecret . B8.pack <$> scale (*3) arbitrary 34 | 35 | newtype Identifier = Identifier { unIdent :: BS.ByteString } deriving (Show) 36 | 37 | instance Arbitrary Identifier where 38 | arbitrary = Identifier . B8.pack <$>(scale (*3) . listOf1 . elements $ ['a'..'z']) 39 | 40 | newtype EquationLike = EquationLike { unEqlike :: BS.ByteString } deriving (Show) 41 | 42 | instance Arbitrary EquationLike where 43 | arbitrary = do 44 | keylen <- choose (3,8) 45 | key <- B8.pack <$> vectorOf keylen (elements ['a'..'z']) 46 | val <- B8.pack <$> (scale (*3) . listOf1 . elements $ ['a'..'z']) 47 | return $ EquationLike (BS.concat [ key, " = ", val]) 48 | 49 | 50 | data SimpleMac = SimpleMac { secret :: BS.ByteString, macaroon :: Macaroon } deriving Show 51 | 52 | instance Arbitrary SimpleMac where 53 | arbitrary = do 54 | secret <- unSecret <$> arbitrary 55 | location <- unUrl <$> arbitrary 56 | ident <- unIdent <$> arbitrary 57 | fpcavs <- listOf arbitrary 58 | let mac = foldl (flip addFirstPartyCaveat) (create secret ident location) (map unEqlike fpcavs) 59 | return $ SimpleMac secret mac 60 | 61 | 62 | -------------------------------------------------------------------------------- /test/Crypto/Macaroon/Serializer/Base64/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | 8 | 9 | This test suite is based on the pymacaroons test suite: 10 | 11 | -} 12 | module Crypto.Macaroon.Serializer.Base64.Tests where 13 | 14 | 15 | import qualified Data.ByteString.Char8 as B8 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | import Test.Tasty.QuickCheck 19 | 20 | import Crypto.Macaroon 21 | 22 | import Crypto.Macaroon.Instances 23 | 24 | tests :: TestTree 25 | tests = testGroup "Crypto.Macaroon.Serializer.Base64" [ basic 26 | , minted 27 | , minted2 28 | , emptyString 29 | -- , minted3 30 | ] 31 | 32 | basicQC = testProperty "Reversibility" $ 33 | \sm -> deserialize (serialize (macaroon sm)) == Right (macaroon sm) 34 | 35 | m :: Macaroon 36 | m = create secret key loc 37 | where 38 | secret = B8.pack "this is our super secret key; only we should know it" 39 | key = B8.pack "we used our secret key" 40 | loc = B8.pack "http://mybank/" 41 | 42 | basic :: TestTree 43 | basic = testGroup "Basic macaroon" [ basicSerialize 44 | , basicDeserialize 45 | , basicQC 46 | ] 47 | 48 | basicSerialize = testCase "Serialization" $ 49 | "MDAxY2xvY2F0aW9uIGh0dHA6Ly9teWJhbmsvCjAwMjZpZGVudG\ 50 | \lmaWVyIHdlIHVzZWQgb3VyIHNlY3JldCBrZXkKMDAyZnNpZ25h\ 51 | \dHVyZSDj2eApCFJsTAA5rhURQRXZf91ovyujebNCqvD2F9BVLwo" @=? serialize m 52 | 53 | basicDeserialize = testCase "Deserialization" $ 54 | Right m @=? (deserialize . serialize) m 55 | 56 | m2 :: Macaroon 57 | m2 = addFirstPartyCaveat "test = caveat" m 58 | 59 | minted :: TestTree 60 | minted = testGroup "Macaroon with first party caveat" [ mintSerialize 61 | , mintDeserialize 62 | ] 63 | 64 | 65 | mintSerialize = testCase "Serialization" $ 66 | "MDAxY2xvY2F0aW9uIGh0dHA6Ly9teWJhbmsvCjAwMjZpZGVudGlmaWVyIHdlIHVzZ\ 67 | \WQgb3VyIHNlY3JldCBrZXkKMDAxNmNpZCB0ZXN0ID0gY2F2ZWF0CjAwMmZzaWduYXR1cmUgGXusegR\ 68 | \K8zMyhluSZuJtSTvdZopmDkTYjOGpmMI9vWcK" @=? serialize m2 69 | 70 | mintDeserialize = testCase "Deserialization" $ 71 | Right m2 @=? (deserialize . serialize) m2 72 | 73 | 74 | m3 :: Macaroon 75 | m3 = addFirstPartyCaveat "test = acaveat" m 76 | 77 | minted2 :: TestTree 78 | minted2 = testGroup "Macaroon with first party caveats" [ mint2Trimmed 79 | , mint2Des 80 | ] 81 | 82 | mint2Trimmed = testCase "Serialization" $ 83 | "MDAxY2xvY2F0aW9uIGh0dHA6Ly9teWJhbmsvCjAwMjZpZGVudGlmaWVyIHdlIHVz\ 84 | \ZWQgb3VyIHNlY3JldCBrZXkKMDAxN2NpZCB0ZXN0ID0gYWNhdmVhdAowMDJmc2ln\ 85 | \bmF0dXJlIJRJ_V3WNJQnqlVq5eez7spnltwU_AXs8NIRY739sHooCg" @=? serialize m3 86 | 87 | mint2Des = testCase "Deserialization" $ 88 | Right m3 @=? (deserialize . serialize) m3 89 | 90 | emptyString :: TestTree 91 | emptyString = testGroup "Empty string" [ emptyStringDes ] 92 | 93 | emptyStringDes = testCase "Deserialization should fail gracefully" $ 94 | Left "Failed reading: missing macaroon header" @=? deserialize "" 95 | -------------------------------------------------------------------------------- /test/Crypto/Macaroon/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | 8 | 9 | This test suite is based on the pymacaroons test suite: 10 | 11 | -} 12 | module Crypto.Macaroon.Tests where 13 | 14 | import qualified Data.ByteString.Char8 as B8 15 | import Data.Hex 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | 19 | import Crypto.Macaroon 20 | 21 | tests :: TestTree 22 | tests = testGroup "Crypto.Macaroon" [ basic 23 | , minted 24 | ] 25 | 26 | 27 | m :: Macaroon 28 | m = create secret key loc 29 | where 30 | secret = B8.pack "this is our super secret key; only we should know it" 31 | key = B8.pack "we used our secret key" 32 | loc = B8.pack "http://mybank/" 33 | 34 | basic :: TestTree 35 | basic = testGroup "Basic macaroon" [ basicInspect 36 | , basicSignature 37 | ] 38 | 39 | basicInspect = testCase "Inspect" $ 40 | "location http://mybank/\nidentifier we used\ 41 | \ our secret key\n\nsignature E3D9E02908526C4C\ 42 | \0039AE15114115D97FDD68BF2BA379B342AAF0F617D0552F" @=? inspect m 43 | 44 | basicSignature = testCase "Signature" $ 45 | "E3D9E02908526C4C0039AE15114115D97FDD68BF2BA379B342AAF0F617D0552F" @=? (hex . signature) m 46 | 47 | m2 :: Macaroon 48 | m2 = addFirstPartyCaveat "test = caveat" m 49 | 50 | minted :: TestTree 51 | minted = testGroup "Macaroon with first party caveat" [ mintInspect 52 | , mintSignature 53 | ] 54 | 55 | mintInspect = testCase "Inspect" $ 56 | "location http://mybank/\nidentifier we used\ 57 | \ our secret key\ncid test = caveat\nsignature\ 58 | \ 197BAC7A044AF33332865B9266E26D49\ 59 | \3BDD668A660E44D88CE1A998C23DBD67" @=? inspect m2 60 | 61 | 62 | mintSignature = testCase "Signature" $ 63 | "197BAC7A044AF33332865B9266E26D493BDD668A660E44D88CE1A998C23DBD67" @=? (hex . signature) m2 64 | 65 | -- m4 :: Macaroon 66 | -- m4 = addThirdPartyCaveat caveat_key caveat_id caveat_loc n 67 | -- where 68 | -- n = addFirstPartyCaveat "account = 3735928559" $ create sec key loc 69 | -- key = B8.pack "we used our other secret key" 70 | -- loc = B8.pack "http://mybank/" 71 | -- sec = B8.pack "this is a different super-secret key; never use the same secret twice" 72 | -- caveat_key = B8.pack "4; guaranteed random by a fair toss of the dice" 73 | -- caveat_id = B8.pack "this was how we remind auth of key/pred" 74 | -- caveat_loc = B8.pack "http://auth.mybank/" 75 | 76 | -- minted3 :: TestTree 77 | -- minted3 = testGroup "Macaroon with first and third party caveats" [ mint3sig ] 78 | 79 | 80 | -- mint3sig = testCase "Signature" $ 81 | -- "6B99EDB2EC6D7A4382071D7D41A0BF7DFA27D87D2F9FEA86E330D7850FFDA2B2" @=? (hex . signature) m4 82 | -------------------------------------------------------------------------------- /test/Crypto/Macaroon/Verifier/Internal/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-| 4 | Copyright : (c) 2015 Julien Tanguy 5 | License : BSD3 6 | 7 | Maintainer : julien.tanguy@jhome.fr 8 | 9 | 10 | This test suite is based on the pymacaroons test suite: 11 | 12 | -} 13 | module Crypto.Macaroon.Verifier.Internal.Tests where 14 | 15 | import Data.Bool 16 | import qualified Data.ByteString as BS 17 | import qualified Data.ByteString.Char8 as B8 18 | import Data.List.NonEmpty (NonEmpty (..)) 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | import Test.Tasty.QuickCheck hiding (Failure, Success) 22 | 23 | import Crypto.Macaroon 24 | import Crypto.Macaroon.Verifier.Internal 25 | 26 | import Crypto.Macaroon.Instances 27 | 28 | tests :: TestTree 29 | tests = testGroup "Crypto.Macaroon.Verifier.Internal" [ sigs 30 | , firstParty 31 | ] 32 | 33 | {- 34 | - Test fixtures 35 | -} 36 | sec = B8.pack "this is our super secret key; only we should know it" 37 | 38 | type VerifierResult' = VerifierResult String String 39 | type VerifierError' = VerifierError String String 40 | type ValidationError' = ValidationError String String 41 | 42 | m :: Macaroon 43 | m = create sec key loc 44 | where 45 | key = B8.pack "we used our sec key" 46 | loc = B8.pack "http://mybank/" 47 | 48 | m2 :: Macaroon 49 | m2 = addFirstPartyCaveat "test = caveat" m 50 | 51 | vtest :: Caveat -> IO VerifierResult' 52 | vtest c = return $ if "test" `BS.isPrefixOf` cid c then 53 | bool (Refused (VerifierError "Failed")) Verified $ "test = caveat" == cid c 54 | else Unrelated 55 | 56 | 57 | m3 :: Macaroon 58 | m3 = addFirstPartyCaveat "value = 42" m2 59 | 60 | vval :: Caveat -> IO VerifierResult' 61 | vval c = return $ if "value" `BS.isPrefixOf` cid c then 62 | bool (Refused (VerifierError "Failed")) Verified $ "value = 42" == cid c 63 | else Unrelated 64 | 65 | 66 | {- 67 | - Tests 68 | -} 69 | 70 | sigs = testProperty "Signatures" $ \sm -> verifySig @String @String (secret sm) (macaroon sm) == Right (macaroon sm) 71 | 72 | getCids :: Either ValidationError' a -> Maybe (NonEmpty (Key, [VerifierError'])) 73 | getCids res = 74 | let errors = either getCaveats (const Nothing) 75 | getCid (cav, errors) = (cid cav, errors) 76 | getCaveats (RemainingCaveats es) = Just $ fmap getCid es 77 | getCaveats _ = Nothing 78 | in errors res 79 | 80 | type CavResult = IO (Either ValidationError' ()) 81 | 82 | firstParty = testGroup "First party caveats" [ 83 | testCase "Zero caveat" $ do 84 | res <- verifyCavs [] (caveats m) :: CavResult 85 | Right () @=? res 86 | , testCase "One caveat empty" $ do 87 | res <- verifyCavs [] (caveats m2) :: CavResult 88 | Just (("test = caveat", []) :| [])@=? getCids res 89 | , testCase "One caveat fail" $ do 90 | res <- verifyCavs [vval] (caveats m2) :: CavResult 91 | Just (("test = caveat", []) :| [])@=? getCids res 92 | , testCase "One caveat win" $ do 93 | res <- verifyCavs [vtest] (caveats m2) :: CavResult 94 | Right () @=? res 95 | , testCase "Two caveat win" $ do 96 | res <- verifyCavs [vtest, vval] (caveats m3) :: CavResult 97 | Right () @=? res 98 | ] 99 | 100 | -------------------------------------------------------------------------------- /test/Crypto/Macaroon/Verifier/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Copyright : (c) 2015 Julien Tanguy 4 | License : BSD3 5 | 6 | Maintainer : julien.tanguy@jhome.fr 7 | 8 | 9 | This test suite is based on the pymacaroons test suite: 10 | 11 | -} 12 | module Crypto.Macaroon.Verifier.Tests where 13 | 14 | 15 | import qualified Data.ByteString.Char8 as B8 16 | import Test.Tasty 17 | 18 | import Crypto.Macaroon 19 | 20 | tests :: TestTree 21 | tests = testGroup "Crypto.Macaroon.Verifier" [ ] 22 | 23 | {- 24 | - Test fixtures 25 | -} 26 | sec = B8.pack "this is our super secret key; only we should know it" 27 | 28 | m :: Macaroon 29 | m = create sec key loc 30 | where 31 | key = B8.pack "we used our sec key" 32 | loc = B8.pack "http://mybank/" 33 | 34 | m2 :: Macaroon 35 | m2 = addFirstPartyCaveat "test = caveat" m 36 | 37 | m3 :: Macaroon 38 | m3 = addFirstPartyCaveat "value = 42" m2 39 | 40 | {- 41 | - Tests 42 | -} 43 | 44 | -- TODO 45 | -------------------------------------------------------------------------------- /test/Sanity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Sanity where 3 | 4 | import Crypto.Hash 5 | import Data.Byteable 6 | import Data.ByteString (ByteString) 7 | import qualified Data.ByteString as B 8 | import Data.Hex 9 | 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | 13 | tests :: TestTree 14 | tests = testGroup "Python HMAC Sanity check" [ checkKey 15 | , checkMac1 16 | , checkMac2 17 | , checkMac3 18 | , checkMac4 19 | ] 20 | 21 | 22 | secret :: ByteString 23 | secret = "this is our super secret key; only we should know it" 24 | 25 | public :: ByteString 26 | public = "we used our secret key" 27 | 28 | key :: ByteString 29 | key = B.take 32 secret 30 | 31 | mac1 :: ByteString 32 | mac1 = toBytes (hmac key public :: HMAC SHA256) 33 | 34 | mac2 :: ByteString 35 | mac2 = toBytes (hmac mac1 "account = 3735928559" :: HMAC SHA256) 36 | 37 | mac3 :: ByteString 38 | mac3 = toBytes (hmac mac2 "time < 2015-01-01T00:00" :: HMAC SHA256) 39 | 40 | mac4 :: ByteString 41 | mac4 = toBytes (hmac mac3 "email = alice@example.org" :: HMAC SHA256) 42 | 43 | 44 | checkKey = testCase "Truncated key" $ 45 | key @?= "this is our super secret key; on" 46 | 47 | checkMac1 = testCase "HMAC key" $ 48 | "C60B4B3540BB1B2F2EF28D1C895691CC4A5E07A38A9D3B1C3379FB485293372F" @=? hex mac1 49 | 50 | checkMac2 = testCase "HMAC key account" $ 51 | "5C933DC9A7D036DFCD1740B4F26D737397A1FF635EAC900F3226973503CAAAA5" @=? hex mac2 52 | 53 | checkMac3 = testCase "HMAC key account time" $ 54 | "7A559B20C8B607009EBCE138C200585E9D0DECA6D23B3EAD6C5E0BA6861D3858" @=? hex mac3 55 | 56 | checkMac4 = testCase "HMAC key account time email" $ 57 | "E42BBB02A9A5A303483CB6295C497AE51AD1D5CB10003CBE548D907E7E62F5E4" @=? hex mac4 58 | 59 | -------------------------------------------------------------------------------- /test/main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Crypto.Macaroon.Serializer.Base64.Tests 6 | import qualified Crypto.Macaroon.Tests 7 | import qualified Crypto.Macaroon.Verifier.Internal.Tests 8 | import qualified Crypto.Macaroon.Verifier.Tests 9 | import qualified Sanity 10 | 11 | main = defaultMain tests 12 | 13 | tests :: TestTree 14 | tests = testGroup "Tests" [ Sanity.tests 15 | , Crypto.Macaroon.Tests.tests 16 | , Crypto.Macaroon.Serializer.Base64.Tests.tests 17 | , Crypto.Macaroon.Verifier.Tests.tests 18 | , Crypto.Macaroon.Verifier.Internal.Tests.tests 19 | ] 20 | 21 | --------------------------------------------------------------------------------