packages feed

paseto (empty) → 0.1.0.0

raw patch · 42 files changed

+5208/−0 lines, 42 filesdep +aesondep +basedep +base16-bytestringsetup-changed

Dependencies added: aeson, base, base16-bytestring, base64-bytestring, basement, binary, bytestring, containers, crypton, deepseq, hedgehog, memory, mtl, parsec, paseto, text, time, transformers-except

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# ChangeLog for paseto++## 0.1.0.0 -- 2024-09-22++- Initial release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2024 intricate++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,14 @@+# paseto-haskell++A Haskell implementation of+[PASETO (**P**latform-**A**gnostic **SE**curity **TO**kens)](https://paseto.io/).++## What is PASETO?++PASETO is everything you love about JOSE (JWT, JWE, JWS) without any of the+[many design deficits that plague the JOSE standards](https://paragonie.com/blog/2017/03/jwt-json-web-tokens-is-bad-standard-that-everyone-should-avoid).++## More Information++For more information about this library and a rundown on how to use it, check+out the [README on GitHub](https://github.com/intricate/paseto-haskell#readme).
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ paseto.cabal view
@@ -0,0 +1,133 @@+cabal-version:       3.4+name:                paseto+version:             0.1.0.0+synopsis:            Platform-Agnostic Security Tokens+description:+  Haskell implementation of PASETO (Platform-Agnostic Security Tokens).+  .+  The recommended entry point for this library is "Crypto.Paseto".+  .+  For more information about this library and a rundown on how to use it,+  check out the+  [README on GitHub](https://github.com/intricate/paseto-haskell#readme).+author:              Luke Nadur+maintainer:          Luke Nadur+license:             MIT+license-file:        LICENSE+category:            Cryptography+homepage:            https://github.com/intricate/paseto-haskell+bug-reports:         https://github.com/intricate/paseto-haskell/issues+build-type:          Simple+extra-source-files:  README.md+extra-doc-files:     CHANGELOG.md++library+  default-language:    Haskell2010+  hs-source-dirs:      src+  default-extensions:  DerivingStrategies+                       GeneralizedNewtypeDeriving+                       NamedFieldPuns+                       NoImplicitPrelude+                       OverloadedStrings++  ghc-options:         -Wall+                       -Wcompat+                       -Wincomplete-record-updates+                       -Wincomplete-uni-patterns+                       -Wpartial-fields+                       -Wredundant-constraints+                       -Wunused-packages++  exposed-modules:     Crypto.Paseto+                       Crypto.Paseto.Keys+                       Crypto.Paseto.Keys.V3+                       Crypto.Paseto.Mode+                       Crypto.Paseto.PreAuthenticationEncoding+                       Crypto.Paseto.Protocol.V3+                       Crypto.Paseto.Protocol.V4+                       Crypto.Paseto.ScrubbedBytes+                       Crypto.Paseto.Token+                       Crypto.Paseto.Token.Build+                       Crypto.Paseto.Token.Claim+                       Crypto.Paseto.Token.Claims+                       Crypto.Paseto.Token.Encoding+                       Crypto.Paseto.Token.Parser+                       Crypto.Paseto.Token.Validation++  other-modules:       Crypto.Paseto.Keys.V3.Internal+                       Data.Binary.Put.Integer++  build-depends:       base >= 4.14 && < 5+                     , aeson >= 2.2.3 && < 2.3+                     , base16-bytestring >= 1.0.2 && < 1.1+                     , base64-bytestring >= 1.2.1 && < 1.3+                     , basement >= 0.0.16 && < 0.1+                     , binary >= 0.8.9 && < 0.9+                     , bytestring >= 0.11.5 && < 0.12+                     , containers >= 0.6.7 && < 0.7+                     , crypton >= 1.0.0 && < 1.1+                     , deepseq >= 1.4.8 && < 1.5+                     , memory >= 0.18.0 && < 0.19+                     , mtl >= 2.2.2 && < 2.3+                     , parsec >= 3.1.16 && < 3.2+                     , text >= 2.0.2 && < 2.1+                     , time >= 1.12.2 && < 1.13+                     , transformers-except >= 0.1.4 && < 0.2++test-suite paseto-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  hs-source-dirs:      test+  default-extensions:  DerivingStrategies+                       GeneralizedNewtypeDeriving+                       NamedFieldPuns+                       NoImplicitPrelude+                       OverloadedStrings++  ghc-options:         -Wall+                       -Wcompat+                       -Wredundant-constraints+                       -Wincomplete-patterns+                       -Wincomplete-record-updates+                       -Wincomplete-uni-patterns+                       -Wunused-imports+                       -Wunused-packages++  other-modules:       Test.Crypto.Paseto.Keys.Gen+                       Test.Crypto.Paseto.Keys.V3.Gen+                       Test.Crypto.Paseto.Keys.V3+                       Test.Crypto.Paseto.PreAuthenticationEncoding+                       Test.Crypto.Paseto.Protocol.V3+                       Test.Crypto.Paseto.Protocol.V4+                       Test.Crypto.Paseto.ScrubbedBytes.Gen+                       Test.Crypto.Paseto.TestVectors+                       Test.Crypto.Paseto.TestVectorTest+                       Test.Crypto.Paseto.Token.Claim+                       Test.Crypto.Paseto.Token.Claim.Gen+                       Test.Crypto.Paseto.Token.Claims+                       Test.Crypto.Paseto.Token.Claims.Gen+                       Test.Crypto.Paseto.Token.Gen+                       Test.Crypto.Paseto.Token.Parser+                       Test.Crypto.Paseto.Token.Validation+                       Test.Crypto.Paseto.Token.Validation.Gen+                       Test.Gen+                       Test.Golden++  build-depends:        base >= 4.14 && < 5+                      , aeson+                      , base16-bytestring+                      , bytestring+                      , containers+                      , crypton+                      , hedgehog+                      , memory+                      , mtl+                      , paseto+                      , text+                      , time+                      , transformers-except++source-repository head+  type:     git+  location: git://github.com/intricate/paseto-haskell.git
+ src/Crypto/Paseto.hs view
@@ -0,0 +1,245 @@+-- | This module is the recommended entry point for this library.+module Crypto.Paseto+  ( -- * Mode+    Version (..)+  , Purpose (..)++    -- * Keys+    -- ** Symmetric keys+  , SymmetricKey (..)+  , symmetricKeyToBytes+  , bytesToSymmetricKeyV3+  , bytesToSymmetricKeyV4+  , generateSymmetricKeyV3+  , generateSymmetricKeyV4+    -- ** Asymmetric keys+    -- *** Signing keys+  , SigningKey (..)+  , signingKeyToBytes+  , bytesToSigningKeyV3+  , bytesToSigningKeyV4+  , generateSigningKeyV3+  , generateSigningKeyV4+    -- | ==== Errors+  , ScalarDecodingError (..)+  , renderScalarDecodingError+    -- *** Verification keys+  , VerificationKey (..)+  , verificationKeyToBytes+  , bytesToVerificationKeyV3+  , bytesToVerificationKeyV4+  , fromSigningKey+    -- | ==== Errors+  , PublicKeyP384DecodingError (..)+  , renderPublicKeyP384DecodingError++    -- * Tokens+  , Token (..)+  , Payload (..)+  , Footer (..)+  , ImplicitAssertion (..)+    -- ** Construction+  , BuildTokenParams (..)+  , getDefaultBuildTokenParams+  , buildTokenV3Local+  , buildTokenV3Public+  , buildTokenV4Local+  , buildTokenV4Public+    -- | === Errors+  , V3LocalBuildError (..)+  , renderV3LocalBuildError+  , V3PublicBuildError (..)+  , renderV3PublicBuildError+    -- ** Encoding and decoding #encodingDecoding#+  , encode+  , ValidatedToken (..)+  , decodeTokenV3Local+  , decodeTokenV3Public+  , decodeTokenV4Local+  , decodeTokenV4Public+    -- | === Errors+  , CommonDecodingError (..)+  , renderCommonDecodingError+  , V3LocalDecodingError (..)+  , renderV3LocalDecodingError+  , V3PublicDecodingError (..)+  , renderV3PublicDecodingError+  , V4LocalDecodingError (..)+  , renderV4LocalDecodingError+  , V4PublicDecodingError (..)+  , renderV4PublicDecodingError+    -- ** Claims+    -- *** Container type+    -- $claimsContainer+  , Claims+    -- *** Claim types+  , Claim (..)+  , Issuer (..)+  , Subject (..)+  , Audience (..)+  , Expiration (..)+  , renderExpiration+  , NotBefore (..)+  , renderNotBefore+  , IssuedAt (..)+  , renderIssuedAt+  , TokenIdentifier (..)+    -- *** Custom claim keys+  , UnregisteredClaimKey+  , mkUnregisteredClaimKey+  , renderUnregisteredClaimKey+    -- ** Validation+    -- *** Rules+  , ValidationRule (..)+  , ClaimMustExist (..)+    -- **** Default rules+  , getDefaultValidationRules+    -- **** Simple rules+  , forAudience+  , identifiedBy+  , issuedBy+  , notExpired+  , subject+  , validAt+  , customClaimEq+    -- | === Errors+  , ValidationError (..)+  , renderValidationError+  , renderValidationErrors+    -- ** Unsafe parsers+    -- $parsers+  , parseTokenV3Local+  , parseTokenV3Public+  , parseTokenV4Local+  , parseTokenV4Public+  ) where++import Crypto.Paseto.Keys+  ( SigningKey (..)+  , SymmetricKey (..)+  , VerificationKey (..)+  , bytesToSigningKeyV3+  , bytesToSigningKeyV4+  , bytesToSymmetricKeyV3+  , bytesToSymmetricKeyV4+  , bytesToVerificationKeyV3+  , bytesToVerificationKeyV4+  , fromSigningKey+  , generateSigningKeyV3+  , generateSigningKeyV4+  , generateSymmetricKeyV3+  , generateSymmetricKeyV4+  , signingKeyToBytes+  , symmetricKeyToBytes+  , verificationKeyToBytes+  )+import Crypto.Paseto.Keys.V3+  ( PublicKeyP384DecodingError (..)+  , ScalarDecodingError (..)+  , renderPublicKeyP384DecodingError+  , renderScalarDecodingError+  )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Crypto.Paseto.Token+  ( Footer (..), ImplicitAssertion (..), Payload (..), Token (..) )+import Crypto.Paseto.Token.Build+  ( BuildTokenParams (..)+  , V3LocalBuildError (..)+  , V3PublicBuildError (..)+  , buildTokenV3Local+  , buildTokenV3Public+  , buildTokenV4Local+  , buildTokenV4Public+  , getDefaultBuildTokenParams+  , renderV3LocalBuildError+  , renderV3PublicBuildError+  )+import Crypto.Paseto.Token.Claim+  ( Audience (..)+  , Claim (..)+  , Expiration (..)+  , IssuedAt (..)+  , Issuer (..)+  , NotBefore (..)+  , Subject (..)+  , TokenIdentifier (..)+  , UnregisteredClaimKey+  , mkUnregisteredClaimKey+  , renderExpiration+  , renderIssuedAt+  , renderNotBefore+  , renderUnregisteredClaimKey+  )+import Crypto.Paseto.Token.Claims ( Claims )+import Crypto.Paseto.Token.Encoding+  ( CommonDecodingError (..)+  , V3LocalDecodingError (..)+  , V3PublicDecodingError (..)+  , V4LocalDecodingError (..)+  , V4PublicDecodingError (..)+  , ValidatedToken (..)+  , decodeTokenV3Local+  , decodeTokenV3Public+  , decodeTokenV4Local+  , decodeTokenV4Public+  , encode+  , renderCommonDecodingError+  , renderV3LocalDecodingError+  , renderV3PublicDecodingError+  , renderV4LocalDecodingError+  , renderV4PublicDecodingError+  )+import Crypto.Paseto.Token.Parser+  ( parseTokenV3Local+  , parseTokenV3Public+  , parseTokenV4Local+  , parseTokenV4Public+  )+import Crypto.Paseto.Token.Validation+  ( ClaimMustExist (..)+  , ValidationError (..)+  , ValidationRule (..)+  , customClaimEq+  , forAudience+  , getDefaultValidationRules+  , identifiedBy+  , issuedBy+  , notExpired+  , renderValidationError+  , renderValidationErrors+  , subject+  , validAt+  )++-- $claimsContainer+--+-- Collection of PASETO token claims.+--+-- Note that we only re-export the 'Claims' type from this module as the rest+-- of the API contains functions which may conflict with those in "Prelude"+-- and other container implementations such as "Data.Map".+--+-- If you need access to those other functions, it's recommended to import+-- "Crypto.Paseto.Token.Claims" qualified. For example:+--+-- @+-- import qualified Crypto.Paseto.Token.Claims as Claims+-- @++-- $parsers+--+-- Note that these parsers are considered __unsafe__ as they /do not/ perform+-- any kind of token validation, cryptographic or otherwise. They simply+-- ensure that the input /looks like/ a well-formed token.+--+-- For typical usage, one should use the decoding functions that perform+-- parsing, cryptographic verification, and validation from the+-- [encoding and decoding](#g:encodingDecoding) section.+--+-- As a result, you should only use these unsafe parsers in specific+-- situations where you really know what you're doing. For example, they can+-- be useful in situations where one wants to parse some information out of a+-- token's footer without first needing to decrypt or verify the token. For+-- more information on this particular scenario, see+-- [Key-ID Support](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/02-Implementation-Guide/01-Payload-Processing.md#key-id-support)+-- in the PASETO specification.
+ src/Crypto/Paseto/Keys.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | PASETO cryptographic keys.+module Crypto.Paseto.Keys+  ( -- * Symmetric keys+    SymmetricKey (..)+  , symmetricKeyToBytes+  , bytesToSymmetricKeyV3+  , bytesToSymmetricKeyV4+  , generateSymmetricKeyV3+  , generateSymmetricKeyV4++    -- * Asymmetric keys+    -- ** Signing keys+  , SigningKey (..)+  , signingKeyToBytes+  , bytesToSigningKeyV3+  , bytesToSigningKeyV4+  , generateSigningKeyV3+  , generateSigningKeyV4+    -- ** Verification keys+  , VerificationKey (..)+  , verificationKeyToBytes+  , bytesToVerificationKeyV3+  , bytesToVerificationKeyV4+  , fromSigningKey+  ) where++import qualified Crypto.Error as Crypto+import qualified Crypto.Paseto.Keys.V3 as V3+import Crypto.Paseto.Mode ( Version (..) )+import Crypto.Paseto.ScrubbedBytes+  ( ScrubbedBytes32 (..), generateScrubbedBytes32, mkScrubbedBytes32 )+import qualified Crypto.PubKey.Ed25519 as Crypto.Ed25519+import Data.ByteArray ( ScrubbedBytes, constEq )+import qualified Data.ByteArray as BA+import Data.ByteString ( ByteString )+import Prelude++------------------------------------------------------------------------------+-- Symmetric keys+------------------------------------------------------------------------------++-- | Symmetric key.+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+data SymmetricKey v where+  -- | Version 3 symmetric key.+  SymmetricKeyV3 :: !ScrubbedBytes32 -> SymmetricKey V3++  -- | Version 4 symmetric key.+  SymmetricKeyV4 :: !ScrubbedBytes32 -> SymmetricKey V4++instance Eq (SymmetricKey v) where+  SymmetricKeyV3 x == SymmetricKeyV3 y = x `constEq` y+  SymmetricKeyV4 x == SymmetricKeyV4 y = x `constEq` y++-- | Get the raw bytes associated with a symmetric key.+symmetricKeyToBytes :: SymmetricKey v -> ScrubbedBytes+symmetricKeyToBytes k =+  case k of+    SymmetricKeyV3 (ScrubbedBytes32 bs) -> bs+    SymmetricKeyV4 (ScrubbedBytes32 bs) -> bs++-- | Construct a version 3 symmetric key from bytes.+--+-- If the provided byte string does not have a length of @32@ (@256@ bits),+-- 'Nothing' is returned.+bytesToSymmetricKeyV3 :: ScrubbedBytes -> Maybe (SymmetricKey V3)+bytesToSymmetricKeyV3 = (SymmetricKeyV3 <$>) . mkScrubbedBytes32++-- | Construct a version 4 symmetric key from bytes.+--+-- If the provided byte string does not have a length of @32@ (@256@ bits),+-- 'Nothing' is returned.+bytesToSymmetricKeyV4 :: ScrubbedBytes -> Maybe (SymmetricKey V4)+bytesToSymmetricKeyV4 = (SymmetricKeyV4 <$>) . mkScrubbedBytes32++-- | Randomly generate a version 3 symmetric key.+generateSymmetricKeyV3 :: IO (SymmetricKey V3)+generateSymmetricKeyV3 = SymmetricKeyV3 <$> generateScrubbedBytes32++-- | Randomly generate a version 4 symmetric key.+generateSymmetricKeyV4 :: IO (SymmetricKey V4)+generateSymmetricKeyV4 = SymmetricKeyV4 <$> generateScrubbedBytes32++------------------------------------------------------------------------------+-- Asymmetric keys+------------------------------------------------------------------------------++-- | Signing key (also known as a private\/secret key).+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+data SigningKey v where+  -- | Version 3 signing key.+  SigningKeyV3 :: !V3.PrivateKeyP384 -> SigningKey V3++  -- | Version 3 signing key.+  SigningKeyV4 :: !Crypto.Ed25519.SecretKey -> SigningKey V4++instance Eq (SigningKey v) where+  x == y = signingKeyToBytes x `constEq` signingKeyToBytes y++-- | Get the raw bytes associated with a signing key.+signingKeyToBytes :: SigningKey v -> ScrubbedBytes+signingKeyToBytes sk =+  case sk of+    SigningKeyV3 k -> V3.encodePrivateKeyP384 k+    SigningKeyV4 k -> BA.convert k++-- | Construct a version 3 signing key from bytes.+bytesToSigningKeyV3 :: ScrubbedBytes -> Either V3.ScalarDecodingError (SigningKey V3)+bytesToSigningKeyV3 bs = SigningKeyV3 <$> V3.decodePrivateKeyP384 bs++-- | Construct a version 4 signing key from bytes.+bytesToSigningKeyV4 :: ScrubbedBytes -> Maybe (SigningKey V4)+bytesToSigningKeyV4 bs =+  SigningKeyV4+    <$> Crypto.maybeCryptoError (Crypto.Ed25519.secretKey bs)++-- | Randomly generate a version 3 signing key.+generateSigningKeyV3 :: IO (SigningKey V3)+generateSigningKeyV3 = SigningKeyV3 <$> V3.generatePrivateKeyP384++-- | Randomly generate a version 4 signing key.+generateSigningKeyV4 :: IO (SigningKey V4)+generateSigningKeyV4 = SigningKeyV4 <$> Crypto.Ed25519.generateSecretKey++-- | Verification key (also known as a public key).+data VerificationKey v where+  -- | Version 3 verification key.+  VerificationKeyV3 :: !V3.PublicKeyP384 -> VerificationKey V3++  -- | Version 4 verification key.+  VerificationKeyV4 :: !Crypto.Ed25519.PublicKey -> VerificationKey V4++deriving instance Eq (VerificationKey v)++-- | Get the raw bytes associated with a verification key.+verificationKeyToBytes :: VerificationKey v -> ByteString+verificationKeyToBytes vk =+  case vk of+    VerificationKeyV3 k -> V3.encodePublicKeyP384 k+    VerificationKeyV4 k -> BA.convert k++-- | Construct a version 3 verification key from bytes.+--+-- The input 'ByteString' is expected to be formatted as either a compressed+-- or uncompressed elliptic curve public key as defined by+-- [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+bytesToVerificationKeyV3 :: ByteString -> Either V3.PublicKeyP384DecodingError (VerificationKey V3)+bytesToVerificationKeyV3 bs = VerificationKeyV3 <$> V3.decodePublicKeyP384 bs++-- | Construct a version 4 verification key from bytes.+bytesToVerificationKeyV4 :: ByteString -> Maybe (VerificationKey V4)+bytesToVerificationKeyV4 bs =+  VerificationKeyV4+    <$> Crypto.maybeCryptoError (Crypto.Ed25519.publicKey bs)++-- | Get the 'VerificationKey' which corresponds to a given 'SigningKey'.+fromSigningKey :: SigningKey v -> VerificationKey v+fromSigningKey sk =+  case sk of+    SigningKeyV3 k -> VerificationKeyV3 (V3.fromPrivateKeyP384 k)+    SigningKeyV4 k -> VerificationKeyV4 (Crypto.Ed25519.toPublic k)
+ src/Crypto/Paseto/Keys/V3.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE PatternSynonyms #-}++-- | P384 ECDSA cryptographic keys.+module Crypto.Paseto.Keys.V3+  ( -- * Curve+    curveP384++    -- * Private key+  , PrivateKeyP384 (PrivateKeyP384)+  , unPrivateKeyP384+  , mkPrivateKeyP384+  , generatePrivateKeyP384+  , encodePrivateKeyP384+  , Internal.ScalarDecodingError (..)+  , Internal.renderScalarDecodingError+  , decodePrivateKeyP384+  -- ** Helpers+  , generateScalarP384+  , isScalarValidP384++    -- * Public key+  , PublicKeyP384 (PublicKeyP384)+  , unPublicKeyP384+  , mkPublicKeyP384+  , fromPrivateKeyP384+  , encodePublicKeyP384+  , Internal.CompressedPointDecodingError (..)+  , Internal.UncompressedPointDecodingError (..)+  , PublicKeyP384DecodingError (..)+  , renderPublicKeyP384DecodingError+  , decodePublicKeyP384+  ) where++import qualified Crypto.Paseto.Keys.V3.Internal as Internal+import qualified Crypto.PubKey.ECC.ECDSA as ECC.ECDSA+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.PubKey.ECC.Types as ECC+import Data.Bifunctor ( bimap )+import Data.ByteArray ( ScrubbedBytes, constEq )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import Data.Text ( Text )+import Prelude++-- | Elliptic curve 'ECC.SEC_p384r1'.+curveP384 :: ECC.Curve+curveP384 = ECC.getCurveByName ECC.SEC_p384r1++------------------------------------------------------------------------------+-- P384 private key+------------------------------------------------------------------------------++-- | Generate a random scalar on the curve 'ECC.SEC_p384r1'.+generateScalarP384 :: IO Integer+generateScalarP384 = ECC.scalarGenerate curveP384++-- | Whether a scalar is valid on the curve 'ECC.SEC_p384r1'.+isScalarValidP384 :: Integer -> Bool+isScalarValidP384 = Internal.isScalarValid curveP384++-- | ECDSA private key for curve 'ECC.SEC_p384r1'.+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+newtype PrivateKeyP384 = MkPrivateKeyP384+  { unPrivateKeyP384 :: ECC.ECDSA.PrivateKey }+  deriving newtype Show++instance Eq PrivateKeyP384 where+  PrivateKeyP384 (ECC.ECDSA.PrivateKey cx dx) == PrivateKeyP384 (ECC.ECDSA.PrivateKey cy dy) =+    Internal.encodeScalar cx dx `constEq` Internal.encodeScalar cy dy++pattern PrivateKeyP384 :: ECC.ECDSA.PrivateKey -> PrivateKeyP384+pattern PrivateKeyP384 pk <- MkPrivateKeyP384 pk++{-# COMPLETE PrivateKeyP384 #-}++-- | Construct a private key for curve 'ECC.SEC_p384r1'.+mkPrivateKeyP384 :: ECC.ECDSA.PrivateKey -> Maybe PrivateKeyP384+mkPrivateKeyP384 privKey@(ECC.ECDSA.PrivateKey curve d)+  | curveP384 == curve && isScalarValidP384 d = Just (MkPrivateKeyP384 privKey)+  | otherwise = Nothing++-- | Generate a private key for curve 'ECC.SEC_p384r1'.+generatePrivateKeyP384 :: IO PrivateKeyP384+generatePrivateKeyP384 =+  MkPrivateKeyP384 . (ECC.ECDSA.PrivateKey curveP384)+    <$> generateScalarP384++-- | Encode a private key into its binary format as defined in+-- [RFC 5915](https://tools.ietf.org/html/rfc5915), i.e. the @privateKey@+-- field described in+-- [section 3](https://datatracker.ietf.org/doc/html/rfc5915#section-3).+encodePrivateKeyP384 :: PrivateKeyP384 -> ScrubbedBytes+encodePrivateKeyP384 (PrivateKeyP384 (ECC.ECDSA.PrivateKey curve d)) =+  Internal.encodeScalar curve d++-- | Decode a private key from its binary format as defined in+-- [RFC 5915](https://tools.ietf.org/html/rfc5915), i.e. the @privateKey@+-- field described in+-- [section 3](https://datatracker.ietf.org/doc/html/rfc5915#section-3).+decodePrivateKeyP384 :: ScrubbedBytes -> Either Internal.ScalarDecodingError PrivateKeyP384+decodePrivateKeyP384 bs =+  MkPrivateKeyP384 . ECC.ECDSA.PrivateKey curve+    <$> Internal.decodeScalar curve bs+  where+    curve :: ECC.Curve+    curve = curveP384++------------------------------------------------------------------------------+-- P384 public key+------------------------------------------------------------------------------++-- | ECDSA public key for curve 'ECC.SEC_p384r1'.+newtype PublicKeyP384 = MkPublicKeyP384+  { unPublicKeyP384 :: ECC.ECDSA.PublicKey }+  deriving newtype (Show, Eq)++pattern PublicKeyP384 :: ECC.ECDSA.PublicKey -> PublicKeyP384+pattern PublicKeyP384 pk <- MkPublicKeyP384 pk++{-# COMPLETE PublicKeyP384 #-}++-- | Construct a public key for curve 'ECC.SEC_p384r1'.+mkPublicKeyP384 :: ECC.ECDSA.PublicKey -> Maybe PublicKeyP384+mkPublicKeyP384 pubKey@(ECC.ECDSA.PublicKey curve point)+  | curveP384 == curve && ECC.isPointValid curve point = Just (MkPublicKeyP384 pubKey)+  | otherwise = Nothing++-- | Construct the 'PublicKeyP384' which corresponds to a given+-- 'PrivateKeyP384'.+fromPrivateKeyP384 :: PrivateKeyP384 -> PublicKeyP384+fromPrivateKeyP384 (PrivateKeyP384 privateKey) =+  MkPublicKeyP384 (Internal.fromPrivateKey privateKey)++-- | Encode an elliptic curve point into its compressed binary format as+-- defined by [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+encodePublicKeyP384 :: PublicKeyP384 -> ByteString+encodePublicKeyP384 (PublicKeyP384 (ECC.ECDSA.PublicKey c p)) =+  case c of+    ECC.CurveFP curvePrime -> Internal.encodePointCompressed curvePrime p+    _ -> error "encodePublicKeyP384: impossible: secp384r1 curve is not a prime curve"++-- | Error decoding a public key for curve 'ECC.SEC_p384r1'.+data PublicKeyP384DecodingError+  = -- | Error decoding a compressed public key.+    PublicKeyP384DecodingCompressedError !Internal.CompressedPointDecodingError+  | -- | Error decoding an uncompressed public key.+    PublicKeyP384DecodingUncompressedError !Internal.UncompressedPointDecodingError+  deriving stock (Show, Eq)++-- | Render a 'PublicKeyP384DecodingError' as 'Text'.+renderPublicKeyP384DecodingError :: PublicKeyP384DecodingError -> Text+renderPublicKeyP384DecodingError err =+  case err of+    PublicKeyP384DecodingCompressedError e ->+      "Failed to decode compressed public key: "+        <> Internal.renderCompressedPointDecodingError e+    PublicKeyP384DecodingUncompressedError e ->+      "Failed to decode uncompressed public key: "+        <> Internal.renderUncompressedPointDecodingError e++-- | Decode a public key from either its compressed or uncompressed binary+-- format as defined by [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+decodePublicKeyP384 :: ByteString -> Either PublicKeyP384DecodingError PublicKeyP384+decodePublicKeyP384 bs+  | len == 49 = bimap PublicKeyP384DecodingCompressedError mkPk (Internal.decodePointCompressed curvePrime bs)+  | otherwise = bimap PublicKeyP384DecodingUncompressedError mkPk (Internal.decodePointUncompressed curvePrime bs)+  where+    len :: Int+    len = BS.length bs++    curve :: ECC.Curve+    curve = curveP384++    curvePrime :: ECC.CurvePrime+    curvePrime =+      case curve of+        ECC.CurveFP c -> c+        _ -> error "decodePublicKeyP384: impossible: secp384r1 curve is not a prime curve"++    mkPk :: ECC.Point -> PublicKeyP384+    mkPk = MkPublicKeyP384 . (ECC.ECDSA.PublicKey curve)
+ src/Crypto/Paseto/Keys/V3/Internal.hs view
@@ -0,0 +1,309 @@+module Crypto.Paseto.Keys.V3.Internal+  ( isScalarValid+  , encodeScalar+  , ScalarDecodingError (..)+  , renderScalarDecodingError+  , decodeScalar++  , encodePointUncompressed+  , encodePointCompressed+  , UncompressedPointDecodingError (..)+  , renderUncompressedPointDecodingError+  , decodePointUncompressed+  , CompressedPointDecodingError (..)+  , renderCompressedPointDecodingError+  , decodePointCompressed+  , fromPrivateKey+  ) where++import Control.Monad ( when )+import qualified Crypto.Number.Basic as Crypto.Number+import qualified Crypto.Number.ModArithmetic as Crypto.Number+import qualified Crypto.Number.Serialize as Crypto.Number+import qualified Crypto.PubKey.ECC.ECDSA as ECC.ECDSA+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.PubKey.ECC.Types as ECC+import Data.ByteArray ( ScrubbedBytes )+import qualified Data.ByteArray as BA+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Word ( Word8 )+import Prelude++curveOrderBytes :: ECC.Curve -> Int+curveOrderBytes curve =+  (Crypto.Number.numBits (ECC.ecc_n $ ECC.common_curve curve) + 7) `div` 8++-- | Whether an elliptic curve scalar value is valid.+isScalarValid :: ECC.Curve -> Integer -> Bool+isScalarValid curve s = s > 0 && s < n+  where+    n :: Integer+    n = (ECC.ecc_n $ ECC.common_curve curve)++-- | Encode an elliptic curve scalar value.+encodeScalar :: ECC.Curve -> Integer -> ScrubbedBytes+encodeScalar curve = Crypto.Number.i2ospOf_ (curveOrderBytes curve)++-- | Error decoding a scalar value.+data ScalarDecodingError+  = -- | Invalid scalar length.+    ScalarDecodingInvalidLengthError+      -- | Expected length+      !Int+      -- | Actual length+      !Int+  | -- | Decoded scalar is invalid for the curve.+    ScalarDecodingInvalidError+  deriving stock (Show, Eq)++-- | Render a 'ScalarDecodingError' as 'Text'.+renderScalarDecodingError :: ScalarDecodingError -> Text+renderScalarDecodingError err =+  case err of+    ScalarDecodingInvalidLengthError expected actual ->+      "Decoded scalar value is of length "+        <> T.pack (show actual)+        <> ", but was expected to be "+        <> T.pack (show expected)+        <> "."+    ScalarDecodingInvalidError -> "Decoded scalar value is invalid for the curve."++-- | Decode an elliptic curve scalar value.+decodeScalar :: ECC.Curve -> ScrubbedBytes -> Either ScalarDecodingError Integer+decodeScalar curve bs+  | expectedLen /= actualLen = Left (ScalarDecodingInvalidLengthError expectedLen actualLen)+  | otherwise =+      let s = Crypto.Number.os2ip bs+      in if isScalarValid curve s then Right s else Left ScalarDecodingInvalidError+  where+    expectedLen :: Int+    expectedLen = curveOrderBytes curve++    actualLen :: Int+    actualLen = BA.length bs++-- | Encode an elliptic curve point into its uncompressed binary format as+-- defined by [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+--+-- Note that this function will only accept a point on an elliptic curve over+-- 𝔽p (i.e. 'ECC.CurvePrime').+encodePointUncompressed :: ECC.CurvePrime -> ECC.Point -> ByteString+encodePointUncompressed curvePrime point+  | ECC.isPointValid curve point =+      case point of+        ECC.Point x y -> do+          let size = ECC.curveSizeBits (ECC.CurveFP curvePrime) `div` 8+          BS.concat+            [ BS.singleton 0x04+            , Crypto.Number.i2ospOf_ size x+            , Crypto.Number.i2ospOf_ size y+            ]+        ECC.PointO -> error "encodePointUncompressed: cannot encode point at infinity"+  | otherwise = error "encodePointUncompressed: point is invalid"+  where+    curve :: ECC.Curve+    curve = ECC.CurveFP curvePrime++-- | Encode an elliptic curve point into its compressed binary format as+-- defined by [SEC 1](https://www.secg.org/sec1-v2.pdf).+--+-- Note that this function will only accept a point on an elliptic curve over+-- 𝔽p (i.e. 'ECC.CurvePrime').+--+-- Adapted from+-- [cryptonite issue #302](https://github.com/haskell-crypto/cryptonite/issues/302#issue-531003322).+encodePointCompressed :: ECC.CurvePrime -> ECC.Point -> ByteString+encodePointCompressed curvePrime point+  | ECC.isPointValid curve point =+      case point of+        -- We are using `i2ospOf_` because `curveSizeBits` ensures that+        -- the number won't have more than that many bytes.+        ECC.Point x y -> prefix y <> Crypto.Number.i2ospOf_ (ECC.curveSizeBits curve `div` 8) x+        ECC.PointO -> error "encodePointCompressed: cannot encode point at infinity"+  | otherwise = error "encodePointCompressed: point is invalid"+  where+    prefix :: Integer -> ByteString+    prefix y+      | odd y = BS.singleton 0x03+      | otherwise = BS.singleton 0x02++    curve :: ECC.Curve+    curve = ECC.CurveFP curvePrime++-- | Error decoding an uncompressed elliptic curve point.+data UncompressedPointDecodingError+  = -- | Prefix is not the expected value (@0x04@).+    UncompressedPointDecodingInvalidPrefixError+      -- | Invalid prefix which was encountered.+      !Word8+  | -- | Length of the provided point is invalid.+    UncompressedPointDecodingInvalidLengthError+      -- | Expected length+      !Int+      -- | Actual length+      !Int+  | -- | Point is invalid for the curve.+    UncompressedPointDecodingInvalidPointError !ECC.Point+  deriving stock (Show, Eq)++-- | Render an 'UncompressedPointDecodingError' as 'Text'.+renderUncompressedPointDecodingError :: UncompressedPointDecodingError -> Text+renderUncompressedPointDecodingError err =+  case err of+    UncompressedPointDecodingInvalidPrefixError invalidPrefix ->+      "Expected prefix "+        <> T.pack (show (0x04 :: Word8))+        <> " for uncompressed point, but encountered "+        <> T.pack (show invalidPrefix)+        <> "."+    UncompressedPointDecodingInvalidLengthError expected actual ->+      "Decoded point length is expected to be "+        <> T.pack (show expected)+        <> ", but it was "+        <> T.pack (show actual)+        <> "."+    UncompressedPointDecodingInvalidPointError _ ->+      "Decoded point is invalid for the curve."++-- | Decode an elliptic curve point from its uncompressed binary format as+-- defined by [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+--+-- Note that this function will only decode a point on an elliptic curve over+-- 𝔽p (i.e. 'ECC.CurvePrime').+decodePointUncompressed :: ECC.CurvePrime -> ByteString -> Either UncompressedPointDecodingError ECC.Point+decodePointUncompressed curvePrime bs = do+  let expectedPointLen :: Int+      expectedPointLen = 1 + ((ECC.curveSizeBits (ECC.CurveFP curvePrime) `div` 8) * 2)++      actualPointLen :: Int+      actualPointLen = BS.length bs++  when+    (expectedPointLen /= actualPointLen)+    (Left $ UncompressedPointDecodingInvalidLengthError expectedPointLen actualPointLen)++  case BS.uncons bs of+    Nothing -> Left (UncompressedPointDecodingInvalidLengthError expectedPointLen 0)+    Just (prefix, rest)+      | prefix == 0x04 ->+          let (xBs, yBs) = BS.splitAt actualPointLen rest+              x = Crypto.Number.os2ip xBs+              y = Crypto.Number.os2ip yBs+              point = ECC.Point x y+          in if ECC.isPointValid (ECC.CurveFP curvePrime) point+            then Right point+            else Left (UncompressedPointDecodingInvalidPointError point)+      | otherwise -> Left (UncompressedPointDecodingInvalidPrefixError prefix)++-- | Error decoding a compressed elliptic curve point.+data CompressedPointDecodingError+  = -- | Prefix is not either of the expected values (@0x02@ or @0x03@).+    CompressedPointDecodingInvalidPrefixError+      -- | Invalid prefix which was encountered.+      !Word8+  | -- | Length of the provided compressed point is invalid.+    CompressedPointDecodingInvalidLengthError+      -- | Expected length+      !Int+      -- | Actual length+      !Int+  | -- | Failed to find the modular square root of a value.+    CompressedPointDecodingModularSquareRootError+  | -- | Point is invalid for the curve.+    CompressedPointDecodingInvalidPointError !ECC.Point+  deriving stock (Show, Eq)++-- | Render an 'CompressedPointDecodingError' as 'Text'.+renderCompressedPointDecodingError :: CompressedPointDecodingError -> Text+renderCompressedPointDecodingError err =+  case err of+    CompressedPointDecodingInvalidPrefixError invalidPrefix ->+      "Expected prefix of either "+        <> T.pack (show (0x02 :: Word8))+        <> " or "+        <> T.pack (show (0x03 :: Word8))+        <> " for compressed point, but encountered "+        <> T.pack (show invalidPrefix)+        <> "."+    CompressedPointDecodingInvalidLengthError expected actual ->+      "Decoded point length is expected to be "+        <> T.pack (show expected)+        <> ", but it was "+        <> T.pack (show actual)+        <> "."+    CompressedPointDecodingModularSquareRootError ->+      "Failed to recover the x-coordinate from the compressed point."+    CompressedPointDecodingInvalidPointError _ ->+      "Decoded point is invalid for the curve."++data EvenOrOddY+  = EvenY+  | OddY++toEvenOrOddY :: Word8 -> Maybe EvenOrOddY+toEvenOrOddY 0x02 = Just EvenY+toEvenOrOddY 0x03 = Just OddY+toEvenOrOddY _ = Nothing++-- | Decode an elliptic curve point from its compressed binary format as+-- defined by [SEC 1](https://www.secg.org/sec1-v2.pdf) and+-- [RFC 5480 section 2.2](https://datatracker.ietf.org/doc/html/rfc5480#section-2.2).+--+-- Note that this function will only decode a point on an elliptic curve over+-- 𝔽p (i.e. 'ECC.CurvePrime').+--+-- Thanks to+-- [cryptonite PR #303](https://github.com/haskell-crypto/cryptonite/pull/303),+-- there's a function that we can use to compute a square root modulo a prime+-- number ('Crypto.Number.squareRoot').+decodePointCompressed :: ECC.CurvePrime -> ByteString -> Either CompressedPointDecodingError ECC.Point+decodePointCompressed curvePrime@(ECC.CurvePrime p curveCommon) bs = do+  let expectedCompressedPointLen :: Int+      expectedCompressedPointLen = 1 + (ECC.curveSizeBits (ECC.CurveFP curvePrime) `div` 8)++      actualCompressedPointLen :: Int+      actualCompressedPointLen = BS.length bs++  when+    (expectedCompressedPointLen /= actualCompressedPointLen)+    (Left $ CompressedPointDecodingInvalidLengthError expectedCompressedPointLen actualCompressedPointLen)++  case BS.uncons bs of+    Just (prefix, rest) ->+      case toEvenOrOddY prefix of+        Nothing -> Left (CompressedPointDecodingInvalidPrefixError prefix)+        Just evenOrOddY -> do+          let x :: Integer+              x = Crypto.Number.os2ip rest++              b :: Integer+              b = ECC.ecc_b curveCommon++          y <-+            case Crypto.Number.squareRoot p ((x ^ (3 :: Integer)) - (x * 3) + b) of+              Nothing -> Left CompressedPointDecodingModularSquareRootError+              Just y' ->+                case (evenOrOddY, odd y') of+                  (EvenY, True) -> Right (p - y')+                  (OddY, False) -> Right (p - y')+                  _ -> Right y'++          let point :: ECC.Point+              point = ECC.Point x y+          if ECC.isPointValid (ECC.CurveFP curvePrime) point+            then Right point+            else Left (CompressedPointDecodingInvalidPointError point)+    Nothing ->+      -- This should be impossible since we checked the length beforehand.+      Left (CompressedPointDecodingInvalidLengthError expectedCompressedPointLen 0)++-- | Construct the 'ECC.ECDSA.PublicKey' which corresponds to a given+-- 'ECC.ECDSA.PrivateKey'.+fromPrivateKey :: ECC.ECDSA.PrivateKey -> ECC.ECDSA.PublicKey+fromPrivateKey (ECC.ECDSA.PrivateKey curve d) =+  ECC.ECDSA.PublicKey curve (ECC.pointBaseMul curve d)
+ src/Crypto/Paseto/Mode.hs view
@@ -0,0 +1,23 @@+module Crypto.Paseto.Mode+  ( Version (..)+  , Purpose (..)+  ) where++import Prelude++-- | PASETO protocol version.+data Version+  = -- | Version 3. Modern NIST cryptography.+    V3+  | -- | Version 4. Modern [Sodium (@libsodium@)](https://doc.libsodium.org/)+    -- cryptography.+    V4+  deriving stock (Show, Eq)++-- | PASETO token purpose.+data Purpose+  = -- | Shared-key authenticated encryption.+    Local+  | -- | Public-key digital signatures (__not encrypted__).+    Public+  deriving stock (Show, Eq)
+ src/Crypto/Paseto/PreAuthenticationEncoding.hs view
@@ -0,0 +1,57 @@+-- | PASETO+-- [Pre-Authentication Encoding (PAE)](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Common.md#authentication-padding).+module Crypto.Paseto.PreAuthenticationEncoding+  ( encode+  , DecodingError (..)+  , decode+  ) where++import Control.Monad ( replicateM )+import Data.Binary.Get+  ( ByteOffset, Get, getByteString, getWord64le, runGetOrFail )+import Data.Binary.Put ( putByteString, putWord64le, runPut )+import Data.Bits ( (.&.) )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Foldable ( for_ )+import Data.Word ( Word64 )+import Prelude++-- | Encode a multipart message using+-- [Pre-Authentication Encoding (PAE)](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Common.md#authentication-padding)+-- as defined in the PASETO spec.+encode :: [ByteString] -> ByteString+encode pieces = BS.toStrict . runPut $ do+  let numPieces :: Word64+      numPieces = fromIntegral $ length pieces+  putWord64le (clearMsb numPieces) -- Clear the MSB for interoperability+  for_ pieces $ \piece -> do+    let pieceLen :: Word64+        pieceLen = fromIntegral $ BS.length piece+    putWord64le (clearMsb pieceLen) -- Clear the MSB for interoperability+    putByteString piece+  where+    -- Clear the most significant bit of a 'Word64'.+    clearMsb :: Word64 -> Word64+    clearMsb w64 = w64 .&. (0x7FFFFFFFFFFFFFFF :: Word64)++-- | Error decoding a PAE-encoded message.+newtype DecodingError = DecodingError (LBS.ByteString, ByteOffset, String)+  deriving newtype (Show, Eq)++-- | Decode a multipart message which has been encoded using+-- [Pre-Authentication Encoding (PAE)](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Common.md#authentication-padding)+-- as defined in the PASETO spec.+decode :: ByteString -> Either DecodingError [ByteString]+decode bs =+  case runGetOrFail getPieces (LBS.fromStrict bs) of+    Left err -> Left (DecodingError err)+    Right (_, _, pieces) -> Right pieces+  where+    getPieces :: Get [ByteString]+    getPieces = do+      numPieces <- getWord64le+      replicateM (fromIntegral numPieces) $ do+        pieceLen <- getWord64le+        getByteString (fromIntegral pieceLen)
+ src/Crypto/Paseto/Protocol/V3.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++-- | Implementation of+-- [PASETO version 3](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md)+-- (modern NIST cryptography).+module Crypto.Paseto.Protocol.V3+  ( -- * Local purpose+    v3LocalTokenHeader+  , EncryptionError (..)+  , renderEncryptionError+  , encrypt+  , encryptPure+  , DecryptionError (..)+  , renderDecryptionError+  , decrypt++    -- * Public purpose+  , v3PublicTokenHeader+  , SigningError (..)+  , renderSigningError+  , sign+  , signPure+  , VerificationError (..)+  , renderVerificationError+  , verify+  ) where++import Control.Monad ( unless, when )+import Control.Monad.Except ( ExceptT, liftIO )+import Control.Monad.Trans.Except.Extra ( hoistEither )+import qualified Crypto.Cipher.AES as Crypto+import qualified Crypto.Cipher.Types as Crypto+import qualified Crypto.Error as Crypto+import qualified Crypto.Hash as Crypto+import qualified Crypto.KDF.HKDF as Crypto+import qualified Crypto.MAC.HMAC as Crypto+import Crypto.Paseto.Keys+  ( SigningKey (..)+  , SymmetricKey (..)+  , VerificationKey (..)+  , fromSigningKey+  , verificationKeyToBytes+  )+import Crypto.Paseto.Keys.V3+  ( PrivateKeyP384 (..)+  , PublicKeyP384 (..)+  , generateScalarP384+  , isScalarValidP384+  )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import qualified Crypto.Paseto.PreAuthenticationEncoding as PAE+import Crypto.Paseto.Token+  ( Footer (..), ImplicitAssertion (..), Payload (..), Token (..) )+import Crypto.Paseto.Token.Claims ( Claims )+import qualified Crypto.PubKey.ECC.ECDSA as Crypto+import qualified Crypto.Random as Crypto+import qualified Data.Aeson as Aeson+import Data.Bifunctor ( first )+import Data.Binary.Put ( runPut )+import Data.Binary.Put.Integer ( putIntegerbe )+import Data.Bits ( shiftL, (.|.) )+import qualified Data.ByteArray as BA+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Prelude++maybeToEither :: a -> Maybe b -> Either a b+maybeToEither _ (Just b) = Right b+maybeToEither a Nothing = Left a++------------------------------------------------------------------------------+-- Local purpose+------------------------------------------------------------------------------++v3LocalTokenHeader :: ByteString+v3LocalTokenHeader = "v3.local."++encryptionKeyHkdfInfoPrefix :: ByteString+encryptionKeyHkdfInfoPrefix = "paseto-encryption-key"++authenticationKeyHkdfInfoPrefix :: ByteString+authenticationKeyHkdfInfoPrefix = "paseto-auth-key-for-aead"++mkAes256Cipher :: ByteString -> Either Crypto.CryptoError Crypto.AES256+mkAes256Cipher ek = Crypto.eitherCryptoError (Crypto.cipherInit ek)++-- | PASETO version 3 encryption error.+data EncryptionError+  = -- | 'Crypto.CryptoError' that occurred during encryption.+    EncryptionCryptoError !Crypto.CryptoError+  | -- | Initialization vector is of an invalid size.+    EncryptionInvalidInitializationVectorSizeError+      -- | Expected size.+      !Int+      -- | Actual size.+      !Int+  deriving stock (Show, Eq)++-- | Render an 'EncryptionError' as 'Text'.+renderEncryptionError :: EncryptionError -> Text+renderEncryptionError err =+  case err of+    EncryptionCryptoError e ->+      "Encountered a cryptographic error: " <> T.pack (show e)+    EncryptionInvalidInitializationVectorSizeError expected actual ->+      "Initialization vector length is expected to be "+        <> T.pack (show expected)+        <> ", but it was "+        <> T.pack (show actual)+        <> "."++-- | Pure variant of 'encrypt'.+--+-- For typical usage, please use 'encrypt'.+encryptPure+  :: ByteString+  -- ^ Random 32-byte nonce.+  --+  -- It is recommended to generate this from the operating system's CSPRNG.+  -> SymmetricKey V3+  -- ^ Symmetric key.+  -> Claims+  -- ^ Claims to be encrypted.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either EncryptionError (Token V3 Local)+encryptPure n (SymmetricKeyV3 k) cs f i = do+  let h :: ByteString+      h = v3LocalTokenHeader++      m :: ByteString+      m = BS.toStrict (Aeson.encode cs)++      prk :: Crypto.PRK Crypto.SHA384+      prk = Crypto.extract BS.empty k++      ek :: ByteString+      n2 :: ByteString+      (ek, n2) = BS.splitAt 32 $ Crypto.expand prk (encryptionKeyHkdfInfoPrefix <> n) 48++      ak :: ByteString+      ak = Crypto.expand prk (authenticationKeyHkdfInfoPrefix <> n) 48++  aes256 <- first EncryptionCryptoError (mkAes256Cipher ek)+  iv <-+    maybeToEither+      (EncryptionInvalidInitializationVectorSizeError (Crypto.blockSize aes256) (BS.length n2))+      (Crypto.makeIV n2)+  let c :: ByteString+      c = Crypto.ctrCombine aes256 iv m++      preAuth :: ByteString+      preAuth = PAE.encode [h, n, c, maybe BS.empty unFooter f, maybe BS.empty unImplicitAssertion i]++      t :: Crypto.HMAC Crypto.SHA384+      t = Crypto.hmac ak preAuth++      payload :: Payload+      payload = Payload (n <> c <> BA.convert t)++  pure $ TokenV3Local payload f++-- | [PASETO version 3 encryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#encrypt).+--+-- This is an authenticated encryption with associated data (AEAD)+-- algorithm which combines the @AES-256-CTR@ block cipher with the+-- @HMAC-SHA384@ message authentication code.+--+-- Note that this function essentially just calls 'encryptPure' with a random+-- 32-byte nonce generated from the operating system's CSPRNG.+encrypt+  :: SymmetricKey V3+  -- ^ Symmetric key.+  -> Claims+  -- ^ Claims to be encrypted.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> ExceptT EncryptionError IO (Token V3 Local)+encrypt k cs f i = do+  n <- liftIO (Crypto.getRandomBytes 32 :: IO ByteString)+  hoistEither (encryptPure n k cs f i)++-- | PASETO version 3 decryption error.+data DecryptionError+  = -- | Invalid token footer.+    DecryptionInvalidFooterError+      -- | Expected footer.+      !(Maybe Footer)+      -- | Actual footer.+      !(Maybe Footer)+  | -- | Invalid @HKDF-HMAC-SHA384@ nonce size.+    DecryptionInvalidHkdfNonceSizeError !Int+  | -- | Invalid @HMAC-SHA384@ message authentication code size.+    DecryptionInvalidHmacSizeError !Int+  | -- | Invalid @HMAC-SHA384@ message authentication code.+    DecryptionInvalidHmacError+      -- | Expected HMAC.+      !ByteString+      -- | Actual HMAC.+      !ByteString+  | -- | 'Crypto.CryptoError' that occurred during decryption.+    DecryptionCryptoError !Crypto.CryptoError+  | -- | Initialization vector is of an invalid size.+    DecryptionInvalidInitializationVectorSizeError+      -- | Expected size.+      !Int+      -- | Actual size.+      !Int+  | -- | Error deserializing a decrypted collection of claims as JSON.+    DecryptionClaimsDeserializationError !String+  deriving stock (Show, Eq)++-- | Render a 'DecryptionError' as 'Text'.+renderDecryptionError :: DecryptionError -> Text+renderDecryptionError err =+  case err of+    DecryptionInvalidFooterError _ _ ->+      -- Since a footer could potentially be very long or some kind of+      -- illegible structured data, we're not going to attempt to render those+      -- values here.+      "Token has an invalid footer."+    DecryptionInvalidHkdfNonceSizeError actual ->+      "Expected nonce with a size of 32, but it was "+        <> T.pack (show actual)+        <> "."+    DecryptionInvalidHmacSizeError actual ->+      "Expected HMAC with a size of 48, but it was "+        <> T.pack (show actual)+        <> "."+    DecryptionInvalidHmacError expected actual ->+      "Expected HMAC value of "+        <> TE.decodeUtf8 (B16.encode expected)+        <> ", but encountered "+        <> TE.decodeUtf8 (B16.encode actual)+        <> "."+    DecryptionCryptoError e ->+      "Encountered a cryptographic error: " <> T.pack (show e)+    DecryptionInvalidInitializationVectorSizeError expected actual ->+      "Initialization vector length is expected to be "+        <> T.pack (show expected)+        <> ", but it was "+        <> T.pack (show actual)+        <> "."+    DecryptionClaimsDeserializationError e ->+      "Error deserializing claims from JSON: " <> T.pack (show e)++-- | [PASETO version 3 decryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#decrypt).+decrypt+  :: SymmetricKey V3+  -- ^ Symmetric key.+  -> Token V3 Local+  -- ^ Token to decrypt.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either DecryptionError Claims+decrypt (SymmetricKeyV3 k) (TokenV3Local (Payload m) actualF) expectedF i = do+  let h :: ByteString+      h = v3LocalTokenHeader++  -- Check that the actual footer matches the provided expected footer.+  when (expectedF /= actualF) (Left $ DecryptionInvalidFooterError expectedF actualF)++  let n :: ByteString+      n = BS.take 32 m++      nLen :: Int+      nLen = BS.length n++      tBs :: ByteString+      tBs = BS.takeEnd 48 m++      mbT :: Maybe (Crypto.HMAC Crypto.SHA384)+      mbT = Crypto.HMAC <$> Crypto.digestFromByteString tBs++      c :: ByteString+      c = BS.dropEnd 48 (BS.drop 32 m)++  when (nLen /= 32) (Left $ DecryptionInvalidHkdfNonceSizeError nLen)++  t <-+    case mbT of+      Nothing -> Left (DecryptionInvalidHmacSizeError $ BS.length tBs)+      Just x -> Right x++  let prk :: Crypto.PRK Crypto.SHA384+      prk = Crypto.extract BS.empty k++      ek :: ByteString+      n2 :: ByteString+      (ek, n2) = BS.splitAt 32 $ Crypto.expand prk (encryptionKeyHkdfInfoPrefix <> n) 48++      ak :: ByteString+      ak = Crypto.expand prk (authenticationKeyHkdfInfoPrefix <> n) 48++      preAuth :: ByteString+      preAuth = PAE.encode [h, n, c, maybe BS.empty unFooter actualF, maybe BS.empty unImplicitAssertion i]++      t2 :: Crypto.HMAC Crypto.SHA384+      t2 = Crypto.hmac ak preAuth++  -- The 'Crypto.HMAC' 'Eq' instance performs a constant-time equality check.+  when (t2 /= t) (Left $ DecryptionInvalidHmacError (BA.convert t2) (BA.convert t))++  aes256 <- first DecryptionCryptoError (mkAes256Cipher ek)+  iv <-+    maybeToEither+      (DecryptionInvalidInitializationVectorSizeError (Crypto.blockSize aes256) (BS.length n2))+      (Crypto.makeIV n2)+  let decrypted :: ByteString+      decrypted = Crypto.ctrCombine aes256 iv c++  -- Deserialize the raw decrypted bytes as a JSON object of claims.+  first DecryptionClaimsDeserializationError (Aeson.eitherDecodeStrict decrypted)++------------------------------------------------------------------------------+-- Public purpose+------------------------------------------------------------------------------++v3PublicTokenHeader :: ByteString+v3PublicTokenHeader = "v3.public."++-- | PASETO version 3 cryptographic signing error.+data SigningError+  = -- | Random number, @k@, is zero.+    SigningKIsZeroError+  deriving (Show, Eq)++-- | Render a 'SigningError' as 'Text'.+renderSigningError :: SigningError -> Text+renderSigningError err =+  case err of+    SigningKIsZeroError -> "Parameter k is 0."++-- | Pure variant of 'sign'.+--+-- For typical usage, please use 'sign'.+signPure+  :: Integer+  -- ^ Explicit @k@ scalar.+  -> SigningKey V3+  -- ^ Signing key.+  -> Claims+  -- ^ Claims to be signed.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either SigningError (Token V3 Public)+signPure k signingKey@(SigningKeyV3 (PrivateKeyP384 sk)) cs f i = do+  let h :: ByteString+      h = v3PublicTokenHeader++      m :: ByteString+      m = BS.toStrict (Aeson.encode cs)++      vk :: VerificationKey V3+      vk = fromSigningKey signingKey++      m2 :: ByteString+      m2 = PAE.encode [verificationKeyToBytes vk, h, m, maybe BS.empty unFooter f, maybe BS.empty unImplicitAssertion i]++  sig <-+    maybeToEither+      SigningKIsZeroError+      (Crypto.signWith k sk Crypto.SHA384 m2)+  let r :: Integer+      r = Crypto.sign_r sig++      s :: Integer+      s = Crypto.sign_s sig++      sigBs :: ByteString+      sigBs =+        padTo 48 (BS.toStrict $ runPut (putIntegerbe r))+          <> padTo 48 (BS.toStrict $ runPut (putIntegerbe s))++      payload :: Payload+      payload = Payload (m <> sigBs)++  Right $ TokenV3Public payload f+    where+      padTo :: Int -> ByteString -> ByteString+      padTo n bs+        | n <= 0 = bs+        | BS.length bs >= n = bs+        | otherwise = BS.replicate (n - BS.length bs) 0 <> bs++-- | [PASETO version 3 cryptographic signing](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#sign).+--+-- This implementation produces a token which is signed using @ECDSA@ over+-- @P-384@ and @SHA-384@.+--+-- Note that this function essentially just calls 'signPure' with a+-- randomly-generated scalar multiple, @k@.+sign+  :: SigningKey V3+  -- ^ Signing key.+  -> Claims+  -- ^ Claims to be signed.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> ExceptT SigningError IO (Token V3 Public)+sign sk cs f i = do+  k <- liftIO generateScalarP384+  hoistEither (signPure k sk cs f i)++-- | PASETO version 3 signature verification error.+data VerificationError+  = -- | Invalid token footer.+    VerificationInvalidFooterError+      -- | Expected footer.+      !(Maybe Footer)+      -- | Actual footer.+      !(Maybe Footer)+  | -- | Signature size is invalid.+    VerificationInvalidSignatureSizeError+  | -- | Signature verification failed.+    VerificationInvalidSignatureError+  | -- | Error deserializing a verified collection of claims as JSON.+    VerificationClaimsDeserializationError !String+  deriving (Show, Eq)++-- | Render a 'VerificationError' as 'Text'.+renderVerificationError :: VerificationError -> Text+renderVerificationError err =+  case err of+    VerificationInvalidFooterError _ _ ->+      -- Since a footer could potentially be very long or some kind of+      -- illegible structured data, we're not going to attempt to render those+      -- values here.+      "Token has an invalid footer."+    VerificationInvalidSignatureSizeError -> "Signature size is invalid."+    VerificationInvalidSignatureError -> "Signature is invalid."+    VerificationClaimsDeserializationError e ->+      "Error deserializing claims from JSON: " <> T.pack (show e)++-- | [PASETO version 3 cryptographic signature verification](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#verify).+verify+  :: VerificationKey V3+  -- ^ Verification key.+  -> Token V3 Public+  -- ^ Token to verify.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either VerificationError Claims+verify verKey@(VerificationKeyV3 (PublicKeyP384 vk)) (TokenV3Public (Payload sm) actualF) expectedF i = do+  let h :: ByteString+      h = v3PublicTokenHeader++  -- Check that the actual footer matches the provided expected footer.+  when (expectedF /= actualF) (Left $ VerificationInvalidFooterError expectedF actualF)++  let sigBs :: ByteString+      sigBs = BS.takeEnd 96 sm++      rBs :: ByteString+      sBs :: ByteString+      (rBs, sBs) = BS.splitAt 48 sigBs++      r :: Integer+      r = bsToInteger rBs++      s :: Integer+      s = bsToInteger sBs++  sig <- sigFromIntegers (r, s)++  let m :: ByteString+      m = BS.dropEnd 96 sm++      m2 :: ByteString+      m2 = PAE.encode [verificationKeyToBytes verKey, h, m, maybe BS.empty unFooter actualF, maybe BS.empty unImplicitAssertion i]++  unless+    (Crypto.verify Crypto.SHA384 vk sig m2)+    (Left VerificationInvalidSignatureError)++  first VerificationClaimsDeserializationError (Aeson.eitherDecodeStrict m)+  where+    -- Decode a big endian 'Integer' from a 'ByteString'.+    --+    -- Ripped from @haskoin-core-1.1.0@.+    bsToInteger :: ByteString -> Integer+    bsToInteger = BS.foldr f 0 . BS.reverse+      where+        f w n = toInteger w .|. shiftL n 8++    mkValidScalar :: Integer -> Either VerificationError Integer+    mkValidScalar s+      | isScalarValidP384 s = Right s+      | otherwise = Left VerificationInvalidSignatureSizeError++    sigFromIntegers :: (Integer, Integer) -> Either VerificationError Crypto.Signature+    sigFromIntegers (r, s) =+      Crypto.Signature <$> mkValidScalar r <*> mkValidScalar s
+ src/Crypto/Paseto/Protocol/V4.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++-- | Implementation of+-- [PASETO version 4](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md)+-- (modern [Sodium](https://doc.libsodium.org/) cryptography).+--+-- Note that we're not actually using @libsodium@ itself in this module but,+-- instead, the equivalent algorithm implementations that are available in+-- @crypton@.+module Crypto.Paseto.Protocol.V4+  ( -- * Local purpose+    v4LocalTokenHeader+  , encrypt+  , encryptPure+  , DecryptionError (..)+  , renderDecryptionError+  , decrypt++    -- * Public purpose+  , v4PublicTokenHeader+  , sign+  , VerificationError (..)+  , renderVerificationError+  , verify+  ) where++import Control.Monad ( unless, when )+import qualified Crypto.Cipher.ChaCha as Crypto+import qualified Crypto.Error as Crypto+import qualified Crypto.Hash as Crypto+import qualified Crypto.MAC.KeyedBlake2 as Crypto+import Crypto.Paseto.Keys+  ( SigningKey (..), SymmetricKey (..), VerificationKey (..) )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import qualified Crypto.Paseto.PreAuthenticationEncoding as PAE+import Crypto.Paseto.Token+  ( Footer (..), ImplicitAssertion (..), Payload (..), Token (..) )+import Crypto.Paseto.Token.Claims ( Claims )+import qualified Crypto.PubKey.Ed25519 as Crypto+import qualified Crypto.Random as Crypto+import qualified Data.Aeson as Aeson+import Data.Bifunctor ( first )+import qualified Data.ByteArray as BA+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Prelude++------------------------------------------------------------------------------+-- Local purpose+------------------------------------------------------------------------------++v4LocalTokenHeader :: ByteString+v4LocalTokenHeader = "v4.local."++encryptionKeyHkdfInfoPrefix :: ByteString+encryptionKeyHkdfInfoPrefix = "paseto-encryption-key"++authenticationKeyHkdfInfoPrefix :: ByteString+authenticationKeyHkdfInfoPrefix = "paseto-auth-key-for-aead"++-- | Pure variant of 'encrypt'.+--+-- For typical usage, please use 'encrypt'.+encryptPure+  :: ByteString+  -- ^ Random 32-byte nonce.+  --+  -- It is recommended to generate this from the operating system's CSPRNG.+  -> SymmetricKey V4+  -- ^ Symmetric key.+  -> Claims+  -- ^ Claims to be encrypted.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Token V4 Local+encryptPure n (SymmetricKeyV4 k) cs f i =+  let h :: ByteString+      h = v4LocalTokenHeader++      m :: ByteString+      m = BS.toStrict (Aeson.encode cs)++      tmp :: Crypto.KeyedBlake2 (Crypto.Blake2b 448)+      tmp = Crypto.keyedBlake2 k (encryptionKeyHkdfInfoPrefix <> n)++      ek :: ByteString+      n2 :: ByteString+      (ek, n2) = BS.splitAt 32 $ BA.convert tmp++      ak :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)+      ak = Crypto.keyedBlake2 k (authenticationKeyHkdfInfoPrefix <> n)++      xChaCha20St :: Crypto.State+      xChaCha20St = Crypto.initializeX 20 ek n2++      c :: ByteString+      (c, _) = Crypto.combine xChaCha20St m++      preAuth :: ByteString+      preAuth = PAE.encode [h, n, c, maybe BS.empty unFooter f, maybe BS.empty unImplicitAssertion i]++      t :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)+      t = Crypto.keyedBlake2 (BA.convert ak :: ByteString) preAuth++      payload :: Payload+      payload = Payload (n <> c <> BA.convert t)++  in TokenV4Local payload f++-- | [PASETO version 4 encryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#encrypt).+--+-- This is an authenticated encryption with associated data (AEAD)+-- algorithm which combines the @XChaCha20@ stream cipher with the @Blake2b@+-- message authentication code.+--+-- Note that this function essentially just calls 'encryptPure' with a random+-- 32-byte nonce generated from the operating system's CSPRNG.+encrypt+  :: SymmetricKey V4+  -- ^ Symmetric key.+  -> Claims+  -- ^ Claims to be encrypted.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> IO (Token V4 Local)+encrypt k cs f i = do+  n <- Crypto.getRandomBytes 32+  pure (encryptPure n k cs f i)++-- | PASETO version 4 decryption error.+data DecryptionError+  = -- | Invalid token footer.+    DecryptionInvalidFooterError+      -- | Expected footer.+      !(Maybe Footer)+      -- | Actual footer.+      !(Maybe Footer)+  | -- | Invalid nonce size.+    DecryptionInvalidNonceSizeError !Int+  | -- | Invalid @Blake2b@ message authentication code size.+    DecryptionInvalidMacSizeError !Int+  | -- | Invalid @Blake2b@ message authenticartion code.+    DecryptionInvalidMacError+      -- | Expected MAC.+      !ByteString+      -- | Actual MAC.+      !ByteString+  | -- | Error deserializing a decrypted collection of claims as JSON.+    DecryptionClaimsDeserializationError !String+  deriving stock (Show, Eq)++-- | Render a 'DecryptionError' as 'Text'.+renderDecryptionError :: DecryptionError -> Text+renderDecryptionError err =+  case err of+    DecryptionInvalidFooterError _ _ ->+      -- Since a footer could potentially be very long or some kind of+      -- illegible structured data, we're not going to attempt to render those+      -- values here.+      "Token has an invalid footer."+    DecryptionInvalidNonceSizeError actual ->+      "Expected nonce with a size of 32, but it was "+        <> T.pack (show actual)+        <> "."+    DecryptionInvalidMacSizeError actual ->+      "Expected MAC with a size of 32, but it was "+        <> T.pack (show actual)+        <> "."+    DecryptionInvalidMacError expected actual ->+      "Expected MAC value of "+        <> TE.decodeUtf8 (B16.encode expected)+        <> ", but encountered "+        <> TE.decodeUtf8 (B16.encode actual)+        <> "."+    DecryptionClaimsDeserializationError e ->+      "Error deserializing claims from JSON: " <> T.pack (show e)++-- | [PASETO version 4 decryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#decrypt).+decrypt+  :: SymmetricKey V4+  -- ^ Symmetric key.+  -> Token V4 Local+  -- ^ Token to decrypt.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either DecryptionError Claims+decrypt (SymmetricKeyV4 k) (TokenV4Local (Payload m) actualF) expectedF i = do+  let h :: ByteString+      h = v4LocalTokenHeader++  -- Check that the actual footer matches the provided expected footer.+  when (expectedF /= actualF) (Left $ DecryptionInvalidFooterError expectedF actualF)++  let n :: ByteString+      n = BS.take 32 m++      nLen :: Int+      nLen = BS.length n++      tBs :: ByteString+      tBs = BS.takeEnd 32 m++      mbT :: Maybe (Crypto.KeyedBlake2 (Crypto.Blake2b 256))+      mbT = Crypto.KeyedBlake2 <$> Crypto.digestFromByteString tBs++      c :: ByteString+      c = BS.dropEnd 32 (BS.drop 32 m)++  when (nLen /= 32) (Left $ DecryptionInvalidNonceSizeError nLen)++  t <-+    case mbT of+      Nothing -> Left (DecryptionInvalidMacSizeError $ BS.length tBs)+      Just x -> Right x++  let tmp :: Crypto.KeyedBlake2 (Crypto.Blake2b 448)+      tmp = Crypto.keyedBlake2 k (encryptionKeyHkdfInfoPrefix <> n)++      ek :: ByteString+      n2 :: ByteString+      (ek, n2) = BS.splitAt 32 $ BA.convert tmp++      ak :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)+      ak = Crypto.keyedBlake2 k (authenticationKeyHkdfInfoPrefix <> n)++      preAuth :: ByteString+      preAuth = PAE.encode [h, n, c, maybe BS.empty unFooter actualF, maybe BS.empty unImplicitAssertion i]++      t2 :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)+      t2 = Crypto.keyedBlake2 (BA.convert ak :: ByteString) preAuth++  -- The 'Crypto.KeyedBlake2' 'Eq' instance performs a constant-time equality check.+  when (t2 /= t) (Left $ DecryptionInvalidMacError (BA.convert t2) (BA.convert t))++  let xChaCha20St :: Crypto.State+      xChaCha20St = Crypto.initializeX 20 ek n2++      decrypted :: ByteString+      (decrypted, _) = Crypto.combine xChaCha20St c++  -- Deserialize the raw decrypted bytes as a JSON object of claims.+  first DecryptionClaimsDeserializationError (Aeson.eitherDecodeStrict decrypted)++------------------------------------------------------------------------------+-- Public purpose+------------------------------------------------------------------------------++v4PublicTokenHeader :: ByteString+v4PublicTokenHeader = "v4.public."++-- | [PASETO version 4 cryptographic signing](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#sign).+--+-- This implementation produces a token which is signed using @Ed25519@.+sign+  :: SigningKey V4+  -- ^ Signing key.+  -> Claims+  -- ^ Claims to be signed.+  -> Maybe Footer+  -- ^ Optional footer to authenticate and encode within the resulting token.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Token V4 Public+sign (SigningKeyV4 sk) cs f i =+  let h :: ByteString+      h = v4PublicTokenHeader++      m :: ByteString+      m = BS.toStrict (Aeson.encode cs)++      m2 :: ByteString+      m2 = PAE.encode [h, m, maybe BS.empty unFooter f, maybe BS.empty unImplicitAssertion i]++      sig :: Crypto.Signature+      sig = Crypto.sign sk (Crypto.toPublic sk) m2++      payload :: Payload+      payload = Payload (m <> BA.convert sig)++  in TokenV4Public payload f++-- | PASETO version 4 signature verification error.+data VerificationError+  = -- | Invalid token footer.+    VerificationInvalidFooterError+      -- | Expected footer.+      !(Maybe Footer)+      -- | Actual footer.+      !(Maybe Footer)+  | -- | 'Crypto.CryptoError' that occurred during verification.+    VerificationCryptoError !Crypto.CryptoError+  | -- | Signature verification failed.+    VerificationInvalidSignatureError+  | -- | Error deserializing a verified collection of claims as JSON.+    VerificationClaimsDeserializationError !String+  deriving (Show, Eq)++-- | Render a 'VerificationError' as 'Text'.+renderVerificationError :: VerificationError -> Text+renderVerificationError err =+  case err of+    VerificationInvalidFooterError _ _ ->+      -- Since a footer could potentially be very long or some kind of+      -- illegible structured data, we're not going to attempt to render those+      -- values here.+      "Token has an invalid footer."+    VerificationCryptoError e ->+      "Encountered a cryptographic error: " <> T.pack (show e)+    VerificationInvalidSignatureError -> "Signature is invalid."+    VerificationClaimsDeserializationError e ->+      "Error deserializing claims from JSON: " <> T.pack (show e)++-- | [PASETO version 4 cryptographic signature verification](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#verify).+verify+  :: VerificationKey V4+  -- ^ Verification key.+  -> Token V4 Public+  -- ^ Token to verify.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Either VerificationError Claims+verify (VerificationKeyV4 vk) (TokenV4Public (Payload sm) actualF) expectedF i = do+  let h :: ByteString+      h = v4PublicTokenHeader++  -- Check that the actual footer matches the provided expected footer.+  when (expectedF /= actualF) (Left $ VerificationInvalidFooterError expectedF actualF)++  s <-+    first VerificationCryptoError+      . Crypto.eitherCryptoError+      $ Crypto.signature (BS.takeEnd 64 sm)++  let m :: ByteString+      m = BS.dropEnd 64 sm++      m2 :: ByteString+      m2 = PAE.encode [h, m, maybe BS.empty unFooter actualF, maybe BS.empty unImplicitAssertion i]++  unless+    (Crypto.verify vk m2 s)+    (Left VerificationInvalidSignatureError)++  first VerificationClaimsDeserializationError (Aeson.eitherDecodeStrict m)
+ src/Crypto/Paseto/ScrubbedBytes.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Crypto.Paseto.ScrubbedBytes+  ( ScrubbedBytes32 (ScrubbedBytes32)+  , mkScrubbedBytes32+  , fromSizedBytes+  , toBytes+  , toSizedBytes+  , generateScrubbedBytes32+  ) where++import Basement.NormalForm ( NormalForm )+import Control.DeepSeq ( NFData (..) )+import qualified Crypto.Random as Crypto+import Data.ByteArray ( ByteArrayAccess, ScrubbedBytes )+import qualified Data.ByteArray as BA+import Data.ByteArray.Sized+  ( ByteArrayN (..), SizedByteArray, sizedByteArray, unSizedByteArray )+import Prelude++-- | Simple wrapper around a 32-byte (256-bit) 'ScrubbedBytes' value.+--+-- Note that this type's 'Eq' instance performs a constant-time equality check.+newtype ScrubbedBytes32 = MkScrubbedBytes32+  { unScrubbedBytes32 :: SizedByteArray 32 ScrubbedBytes }+  deriving newtype (Show, Eq, Ord, NormalForm, ByteArrayAccess)++instance NFData ScrubbedBytes32 where+  rnf (MkScrubbedBytes32 bs) = rnf (unSizedByteArray bs)++instance ByteArrayN 32 ScrubbedBytes32 where+  allocRet p f = do+    (a, ba) <- allocRet p f+    pure (a, MkScrubbedBytes32 ba)++pattern ScrubbedBytes32 :: ScrubbedBytes -> ScrubbedBytes32+pattern ScrubbedBytes32 bs <- (unSizedByteArray . unScrubbedBytes32 -> bs)++{-# COMPLETE ScrubbedBytes32 #-}++-- | Construct a 32-byte (256-bit) 'ScrubbedBytes' value from an array of+-- bytes.+mkScrubbedBytes32 :: ByteArrayAccess b => b -> Maybe ScrubbedBytes32+mkScrubbedBytes32 = (MkScrubbedBytes32 <$>) . sizedByteArray . BA.convert++-- | Construct a 'ScrubbedBytes32' value from a 'SizedByteArray' of+-- 'ScrubbedBytes'.+fromSizedBytes :: SizedByteArray 32 ScrubbedBytes -> ScrubbedBytes32+fromSizedBytes bs = MkScrubbedBytes32 bs++-- | Convert a 'ScrubbedBytes32' value to 'ScrubbedBytes'.+toBytes :: ScrubbedBytes32 -> ScrubbedBytes+toBytes (ScrubbedBytes32 bs) = bs++-- | Convert a 'ScrubbedBytes32' value to a 'SizedByteArray' of+-- 'ScrubbedBytes'.+toSizedBytes :: ScrubbedBytes32 -> SizedByteArray 32 ScrubbedBytes+toSizedBytes (MkScrubbedBytes32 bs) = bs++-- | Randomly generate a 'ScrubbedBytes32' value.+generateScrubbedBytes32 :: IO ScrubbedBytes32+generateScrubbedBytes32 = do+  bs <- Crypto.getRandomBytes 32 :: IO ScrubbedBytes+  case mkScrubbedBytes32 bs of+    Just x -> pure x+    Nothing -> error "generateScrubbedBytes32: impossible: failed to randomly generate 32 bytes"
+ src/Crypto/Paseto/Token.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}++module Crypto.Paseto.Token+  ( Footer (..)++  , ImplicitAssertion (..)++  , Payload (..)++  , Token (..)+  , SomeToken (..)+  , toSomeToken+  ) where++import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Data.ByteArray ( constEq )+import Data.ByteString ( ByteString )+import Prelude++-- | Footer consisting of unencrypted free-form data.+--+-- The footer's contents may be JSON or some other structured data, but it+-- doesn't have to be.+--+-- When a PASETO token is constructed, the footer is authenticated, but not+-- encrypted (i.e. its integrity is protected, but it is not made+-- confidential). In authenticated encryption schemes, this is referred to as+-- \"associated data\".+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+newtype Footer = Footer+  { unFooter :: ByteString }+  deriving newtype (Show)++instance Eq Footer where+  Footer x == Footer y = x `constEq` y++-- | Unencrypted authenticated data which is not stored in the PASETO token.+--+-- When a PASETO token is constructed, the implicit assertion is+-- authenticated, but it is not stored in the token. This is useful if one+-- wants to associate some data that should remain confidential.+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+newtype ImplicitAssertion = ImplicitAssertion+  { unImplicitAssertion :: ByteString }+  deriving newtype (Show)++instance Eq ImplicitAssertion where+  ImplicitAssertion x == ImplicitAssertion y = x `constEq` y++-- | Raw PASETO token payload.+--+-- Note that this type's 'Eq' instance performs a constant-time equality+-- check.+newtype Payload = Payload+  { unPayload :: ByteString }+  deriving newtype (Show)++instance Eq Payload where+  Payload x == Payload y = x `constEq` y++-- | PASETO token parameterized by its protocol 'Version' and 'Purpose'.+data Token v p where+  -- | PASETO version 3 local token.+  TokenV3Local+    :: !Payload+    -- ^ Encrypted token payload.+    -> !(Maybe Footer)+    -- ^ Optional footer (associated data).+    -> Token V3 Local++  -- | PASETO version 3 public token.+  TokenV3Public+    :: !Payload+    -- ^ Signed token payload.+    -> !(Maybe Footer)+    -- ^ Optional footer (associated data).+    -> Token V3 Public++  -- | PASETO version 4 local token.+  TokenV4Local+    :: !Payload+    -- ^ Encrypted token payload.+    -> !(Maybe Footer)+    -- ^ Optional footer (associated data).+    -> Token V4 Local++  -- | PASETO version 4 public token.+  TokenV4Public+    :: !Payload+    -- ^ Signed token payload.+    -> !(Maybe Footer)+    -- ^ Optional footer (associated data).+    -> Token V4 Public++deriving instance Show (Token v p)++instance Eq (Token v p) where+  TokenV3Local px fx == TokenV3Local py fy = px == py && fx == fy+  TokenV3Public px fx == TokenV3Public py fy = px == py && fx == fy+  TokenV4Local px fx == TokenV4Local py fy = px == py && fx == fy+  TokenV4Public px fx == TokenV4Public py fy = px == py && fx == fy++-- | Some kind of PASETO token.+data SomeToken+  = SomeTokenV3Local !(Token V3 Local)+  | SomeTokenV3Public !(Token V3 Public)+  | SomeTokenV4Local !(Token V4 Local)+  | SomeTokenV4Public !(Token V4 Public)+  deriving stock (Show, Eq)++-- | Convert a 'Token' to a 'SomeToken'.+toSomeToken :: Token v p -> SomeToken+toSomeToken t =+  case t of+    TokenV3Local _ _ -> SomeTokenV3Local t+    TokenV3Public _ _ -> SomeTokenV3Public t+    TokenV4Local _ _ -> SomeTokenV4Local t+    TokenV4Public _ _ -> SomeTokenV4Public t
+ src/Crypto/Paseto/Token/Build.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DataKinds #-}++module Crypto.Paseto.Token.Build+  ( BuildTokenParams (..)+  , getDefaultBuildTokenParams+  , V3LocalBuildError (..)+  , renderV3LocalBuildError+  , buildTokenV3Local+  , V3PublicBuildError (..)+  , renderV3PublicBuildError+  , buildTokenV3Public+  , buildTokenV4Local+  , buildTokenV4Public+  ) where++import Control.Monad.Except ( ExceptT )+import Control.Monad.Trans.Except.Extra ( firstExceptT )+import Crypto.Paseto.Keys ( SigningKey (..), SymmetricKey (..) )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import qualified Crypto.Paseto.Protocol.V3 as V3+import qualified Crypto.Paseto.Protocol.V4 as V4+import Crypto.Paseto.Token ( Footer, ImplicitAssertion, Token (..) )+import Crypto.Paseto.Token.Claim+  ( Claim (..), Expiration (..), IssuedAt (..), NotBefore (..) )+import Crypto.Paseto.Token.Claims ( Claims )+import qualified Crypto.Paseto.Token.Claims as Claims+import Data.Text ( Text )+import Data.Time.Clock ( addUTCTime, getCurrentTime, secondsToNominalDiffTime )+import Prelude hiding ( exp )++-- | Parameters for building a PASETO token.+data BuildTokenParams = BuildTokenParams+  { btpClaims :: !Claims+  , btpFooter :: !(Maybe Footer)+  , btpImplicitAssertion :: !(Maybe ImplicitAssertion)+  } deriving stock (Show, Eq)++-- | Get parameters for building a PASETO token which includes the+-- [recommended default claims](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/02-Implementation-Guide/05-API-UX.md#secure-defaults).+--+-- This includes the following default claims:+--+-- * An 'ExpirationClaim' of 1 hour from the current system time.+-- * An 'IssuedAtClaim' of the current system time.+-- * A 'NotBeforeClaim' of the current system time.+--+-- The default 'Footer' and 'ImplicitAssertion' is 'Nothing'.+getDefaultBuildTokenParams :: IO BuildTokenParams+getDefaultBuildTokenParams = do+  now <- getCurrentTime+  let hourInSeconds = 3600+      exp = ExpirationClaim . Expiration $ addUTCTime (secondsToNominalDiffTime hourInSeconds) now+      iat = IssuedAtClaim (IssuedAt now)+      nbf = NotBeforeClaim (NotBefore now)+  pure BuildTokenParams+    { btpClaims = Claims.fromList [exp, iat, nbf]+    , btpFooter = Nothing+    , btpImplicitAssertion = Nothing+    }++-- | Error building a version 3 local PASETO token.+newtype V3LocalBuildError+  = -- | Encryption error.+    V3LocalBuildEncryptionError V3.EncryptionError+  deriving stock (Show, Eq)++-- | Render a 'V3LocalBuildError' as 'Text'.+renderV3LocalBuildError :: V3LocalBuildError -> Text+renderV3LocalBuildError err =+  case err of+    V3LocalBuildEncryptionError e -> V3.renderEncryptionError e++-- | Build a version 3 local token.+buildTokenV3Local :: BuildTokenParams -> SymmetricKey V3 -> ExceptT V3LocalBuildError IO (Token V3 Local)+buildTokenV3Local btp k =+  firstExceptT V3LocalBuildEncryptionError $+    V3.encrypt k btpClaims btpFooter btpImplicitAssertion+  where+    BuildTokenParams+      { btpClaims+      , btpFooter+      , btpImplicitAssertion+      } = btp++-- | Error building a version 3 public PASETO token.+newtype V3PublicBuildError+  = -- | Cryptographic signing error.+    V3PublicBuildSigningError V3.SigningError+  deriving stock (Show, Eq)++-- | Render a 'V3PublicBuildError' as 'Text'.+renderV3PublicBuildError :: V3PublicBuildError -> Text+renderV3PublicBuildError err =+  case err of+    V3PublicBuildSigningError e -> V3.renderSigningError e++-- | Build a version 3 public token.+buildTokenV3Public :: BuildTokenParams -> SigningKey V3 -> ExceptT V3PublicBuildError IO (Token V3 Public)+buildTokenV3Public btp sk =+  firstExceptT V3PublicBuildSigningError $+    V3.sign sk btpClaims btpFooter btpImplicitAssertion+  where+    BuildTokenParams+      { btpClaims+      , btpFooter+      , btpImplicitAssertion+      } = btp++-- | Build a version 4 local token.+buildTokenV4Local :: BuildTokenParams -> SymmetricKey V4 -> IO (Token V4 Local)+buildTokenV4Local btp k = V4.encrypt k btpClaims btpFooter btpImplicitAssertion+  where+    BuildTokenParams+      { btpClaims+      , btpFooter+      , btpImplicitAssertion+      } = btp++-- | Build a version 4 public token.+buildTokenV4Public :: BuildTokenParams -> SigningKey V4 -> Token V4 Public+buildTokenV4Public btp sk = V4.sign sk btpClaims btpFooter btpImplicitAssertion+  where+    BuildTokenParams+      { btpClaims+      , btpFooter+      , btpImplicitAssertion+      } = btp
+ src/Crypto/Paseto/Token/Claim.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | PASETO token claim.+module Crypto.Paseto.Token.Claim+  ( -- * Claim value types+    Issuer (..)+  , Subject (..)+  , Audience (..)+  , Expiration (..)+  , renderExpiration+  , NotBefore (..)+  , renderNotBefore+  , IssuedAt (..)+  , renderIssuedAt+  , TokenIdentifier (..)++    -- * Claim key+  , ClaimKey+      ( IssuerClaimKey+      , SubjectClaimKey+      , AudienceClaimKey+      , ExpirationClaimKey+      , NotBeforeClaimKey+      , IssuedAtClaimKey+      , TokenIdentifierClaimKey+      , CustomClaimKey+      )+  , renderClaimKey+  , parseClaimKey+  , registeredClaimKeys+    -- ** Unregistered claim key+  , UnregisteredClaimKey+  , mkUnregisteredClaimKey+  , renderUnregisteredClaimKey++    -- * Claim+  , Claim (..)+  , claimKey+  , claimToPair+  , claimFromJson+  ) where++import Data.Aeson ( FromJSON (..), ToJSON (..) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson+import qualified Data.Aeson.Types as Aeson+import Data.Set ( Set )+import qualified Data.Set as Set+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Time.Clock ( UTCTime )+import Data.Time.Format.ISO8601 ( iso8601Show )+import Prelude++------------------------------------------------------------------------------+-- Claim value types+------------------------------------------------------------------------------++-- | Issuer of a token.+newtype Issuer = Issuer+  { unIssuer :: Text }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Subject of a token.+newtype Subject = Subject+  { unSubject :: Text }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Recipient for which a token is intended.+newtype Audience = Audience+  { unAudience :: Text }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Time after which a token expires.+newtype Expiration = Expiration+  { unExpiration :: UTCTime }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Render an 'Expiration' as 'Text'.+renderExpiration :: Expiration -> Text+renderExpiration (Expiration t) = T.pack (iso8601Show t)++-- | Time from which a token should be considered valid.+newtype NotBefore = NotBefore+  { unNotBefore :: UTCTime }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Render a 'NotBefore' as 'Text'.+renderNotBefore :: NotBefore -> Text+renderNotBefore (NotBefore t) = T.pack (iso8601Show t)++-- | Time at which a token was issued.+newtype IssuedAt = IssuedAt+  { unIssuedAt :: UTCTime }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++-- | Render an 'IssuedAt' as 'Text'.+renderIssuedAt :: IssuedAt -> Text+renderIssuedAt (IssuedAt t) = T.pack (iso8601Show t)++-- | Token identifier.+newtype TokenIdentifier = TokenIdentifier+  { unTokenIdentifier :: Text }+  deriving newtype (Show, Eq, ToJSON, FromJSON)++------------------------------------------------------------------------------+-- Claim key+------------------------------------------------------------------------------++-- | Token claim key.+newtype ClaimKey = MkClaimKey Text+  deriving newtype (Show, Eq)++instance Ord ClaimKey where+  x `compare` y = renderClaimKey x `compare` renderClaimKey y++-- | Render a 'ClaimKey' as 'Text'.+renderClaimKey :: ClaimKey -> Text+renderClaimKey (MkClaimKey t) = t++-- | Parse a 'ClaimKey' from 'Text'.+parseClaimKey :: Text -> ClaimKey+parseClaimKey = MkClaimKey++pattern IssuerClaimKey :: ClaimKey+pattern IssuerClaimKey = MkClaimKey "iss"++pattern SubjectClaimKey :: ClaimKey+pattern SubjectClaimKey = MkClaimKey "sub"++pattern AudienceClaimKey :: ClaimKey+pattern AudienceClaimKey = MkClaimKey "aud"++pattern ExpirationClaimKey :: ClaimKey+pattern ExpirationClaimKey = MkClaimKey "exp"++pattern NotBeforeClaimKey :: ClaimKey+pattern NotBeforeClaimKey = MkClaimKey "nbf"++pattern IssuedAtClaimKey :: ClaimKey+pattern IssuedAtClaimKey = MkClaimKey "iat"++pattern TokenIdentifierClaimKey :: ClaimKey+pattern TokenIdentifierClaimKey = MkClaimKey "jti"++pattern CustomClaimKey :: UnregisteredClaimKey -> ClaimKey+pattern CustomClaimKey k <- (mkUnregisteredClaimKey . renderClaimKey -> Just k) where+  CustomClaimKey (UnregisteredClaimKey k) = MkClaimKey k++{-# COMPLETE IssuerClaimKey, SubjectClaimKey, AudienceClaimKey, ExpirationClaimKey, NotBeforeClaimKey, IssuedAtClaimKey, TokenIdentifierClaimKey, CustomClaimKey #-}++-- | Registered claims as defined by the+-- [PASETO specification](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/02-Implementation-Guide/04-Claims.md#registered-claims).+registeredClaimKeys :: Set ClaimKey+registeredClaimKeys =+  Set.fromList+    [ IssuerClaimKey+    , SubjectClaimKey+    , AudienceClaimKey+    , ExpirationClaimKey+    , NotBeforeClaimKey+    , IssuedAtClaimKey+    , TokenIdentifierClaimKey+    ]++------------------------------------------------------------------------------+-- Unregistered claim key+------------------------------------------------------------------------------++-- | Unregistered claim key.+newtype UnregisteredClaimKey = UnregisteredClaimKey Text+  deriving newtype (Show, Eq)++-- | Construct an unregistered claim key.+--+-- If the provided @Text@ key matches that of a registered claim+-- ('registeredClaimKeys'), this function will return 'Nothing'.+mkUnregisteredClaimKey :: Text -> Maybe UnregisteredClaimKey+mkUnregisteredClaimKey t+  | Set.member (MkClaimKey t) registeredClaimKeys = Nothing+  | otherwise = Just (UnregisteredClaimKey t)++-- | Render an 'UnregisteredClaimKey' as 'Text'.+renderUnregisteredClaimKey :: UnregisteredClaimKey -> Text+renderUnregisteredClaimKey (UnregisteredClaimKey t) = t++------------------------------------------------------------------------------+-- Claim+------------------------------------------------------------------------------++-- | Token claim.+data Claim+  = IssuerClaim !Issuer+  | SubjectClaim !Subject+  | AudienceClaim !Audience+  | ExpirationClaim !Expiration+  | NotBeforeClaim !NotBefore+  | IssuedAtClaim !IssuedAt+  | TokenIdentifierClaim !TokenIdentifier+  | CustomClaim+      -- | Claim key.+      !UnregisteredClaimKey+      -- | Claim value.+      !Aeson.Value+  deriving stock (Show, Eq)++-- | Get the JSON object key which corresponds to a 'Claim'.+claimKey :: Claim -> ClaimKey+claimKey c =+  case c of+    IssuerClaim _ -> IssuerClaimKey+    SubjectClaim _ -> SubjectClaimKey+    AudienceClaim _ -> AudienceClaimKey+    ExpirationClaim _ -> ExpirationClaimKey+    NotBeforeClaim _ -> NotBeforeClaimKey+    IssuedAtClaim _ -> IssuedAtClaimKey+    TokenIdentifierClaim _ -> TokenIdentifierClaimKey+    CustomClaim k _ -> CustomClaimKey k++claimToPair :: Claim -> Aeson.Pair+claimToPair c = (,) (Aeson.fromText . renderClaimKey $ claimKey c) $+  case c of+    IssuerClaim v -> toJSON v+    SubjectClaim v -> toJSON v+    AudienceClaim v -> toJSON v+    ExpirationClaim v -> toJSON v+    NotBeforeClaim v -> toJSON v+    IssuedAtClaim v -> toJSON v+    TokenIdentifierClaim v -> toJSON v+    CustomClaim _ v -> v++claimFromJson :: Aeson.Key -> Aeson.Value -> Aeson.Parser Claim+claimFromJson k v =+  case parseClaimKey (Aeson.toText k) of+    IssuerClaimKey -> IssuerClaim <$> parseJSON v+    SubjectClaimKey -> SubjectClaim <$> parseJSON v+    AudienceClaimKey -> AudienceClaim <$> parseJSON v+    ExpirationClaimKey -> ExpirationClaim <$> parseJSON v+    NotBeforeClaimKey -> NotBeforeClaim <$> parseJSON v+    IssuedAtClaimKey -> IssuedAtClaim <$> parseJSON v+    TokenIdentifierClaimKey -> TokenIdentifierClaim <$> parseJSON v+    CustomClaimKey x -> CustomClaim x <$> parseJSON v
+ src/Crypto/Paseto/Token/Claims.hs view
@@ -0,0 +1,207 @@+-- | Collection of PASETO token claims.+--+-- It is recommended to import this module qualified since it contains+-- functions which may conflict with those in "Prelude" and other container+-- implementations such as "Data.Map".+--+-- For example:+--+-- @+-- import Crypto.Paseto.Token.Claims (Claims)+-- import qualified Crypto.Paseto.Token.Claims as Claims+-- @+module Crypto.Paseto.Token.Claims+  ( -- * Claims type+    Claims++    -- * Construction+  , empty+  , singleton+    -- ** Insertion+  , insert+    -- ** Deletion+  , delete++    -- * Query+  , lookupIssuer+  , lookupSubject+  , lookupAudience+  , lookupExpiration+  , lookupNotBefore+  , lookupIssuedAt+  , lookupTokenIdentifier+  , lookupCustom+  , null+  , size++    -- * Conversion+  , toList+  , fromList+  ) where++import Control.Monad ( foldM )+import Crypto.Paseto.Token.Claim+  ( Audience+  , Claim (..)+  , ClaimKey (..)+  , Expiration+  , IssuedAt+  , Issuer+  , NotBefore+  , Subject+  , TokenIdentifier+  , UnregisteredClaimKey+  , claimFromJson+  , claimKey+  , claimToPair+  , parseClaimKey+  )+import Data.Aeson ( FromJSON (..), ToJSON (..) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson+import qualified Data.Aeson.KeyMap as Aeson+import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map+import Prelude hiding ( lookup, null )++------------------------------------------------------------------------------+-- Claims type+------------------------------------------------------------------------------++-- | Collection of 'Claim's.+newtype Claims = Claims+  { unClaims :: Map ClaimKey Claim }+  deriving newtype (Show, Eq, Semigroup, Monoid)++instance ToJSON Claims where+  toJSON = Aeson.object . map (claimToPair . snd) . Map.toList . unClaims++instance FromJSON Claims where+  parseJSON = Aeson.withObject "Claims" $ \o -> do+    let kvs = Aeson.toList o+    foldM parseAndAccumClaims empty kvs+    where+      parseAndAccumClaims (Claims acc) (k, v) = do+        c <- claimFromJson k v+        pure . Claims $ Map.insert (parseClaimKey $ Aeson.toText k) c acc++------------------------------------------------------------------------------+-- Construction+------------------------------------------------------------------------------++-- | Empty collection of claims.+empty :: Claims+empty = Claims Map.empty++-- | Construct a collection of claims with a single element.+singleton :: Claim -> Claims+singleton c = Claims $ Map.singleton (claimKey c) c++-- | Insert a 'Claim' into a collection of 'Claims'.+--+-- Note that if a claim with the same key is already present, it is replaced+-- with the provided claim.+insert :: Claim -> Claims -> Claims+insert c = Claims . Map.insert (claimKey c) c . unClaims++-- | Delete a claim from the collection.+delete :: ClaimKey -> Claims -> Claims+delete k = Claims . Map.delete k . unClaims++------------------------------------------------------------------------------+-- Query+------------------------------------------------------------------------------++-- | Lookup a 'Claim' by its key.+--+-- Note that this function is not intended to be exported as it can be a bit+-- error prone.+lookup :: ClaimKey -> Claims -> Maybe Claim+lookup k = Map.lookup k . unClaims++-- | Lookup the issuer claim.+lookupIssuer :: Claims -> Maybe Issuer+lookupIssuer cs =+  case lookup IssuerClaimKey cs of+    Nothing -> Nothing+    Just (IssuerClaim i) -> Just i+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the subject claim.+lookupSubject :: Claims -> Maybe Subject+lookupSubject cs =+  case lookup SubjectClaimKey cs of+    Nothing -> Nothing+    Just (SubjectClaim s) -> Just s+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the audience claim.+lookupAudience :: Claims -> Maybe Audience+lookupAudience cs =+  case lookup AudienceClaimKey cs of+    Nothing -> Nothing+    Just (AudienceClaim a) -> Just a+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the expiration claim.+lookupExpiration :: Claims -> Maybe Expiration+lookupExpiration cs =+  case lookup ExpirationClaimKey cs of+    Nothing -> Nothing+    Just (ExpirationClaim e) -> Just e+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the \"not before\" claim.+lookupNotBefore :: Claims -> Maybe NotBefore+lookupNotBefore cs =+  case lookup NotBeforeClaimKey cs of+    Nothing -> Nothing+    Just (NotBeforeClaim nb) -> Just nb+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the \"issued at\" claim.+lookupIssuedAt :: Claims -> Maybe IssuedAt+lookupIssuedAt cs =+  case lookup IssuedAtClaimKey cs of+    Nothing -> Nothing+    Just (IssuedAtClaim ia) -> Just ia+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup the token identifier claim.+lookupTokenIdentifier :: Claims -> Maybe TokenIdentifier+lookupTokenIdentifier cs =+  case lookup TokenIdentifierClaimKey cs of+    Nothing -> Nothing+    Just (TokenIdentifierClaim ti) -> Just ti+    Just _ -> error "impossible: invalid claim for key"++-- | Lookup a custom unregistered claim.+lookupCustom :: UnregisteredClaimKey -> Claims -> Maybe Aeson.Value+lookupCustom k cs =+  case lookup (CustomClaimKey k) cs of+    Nothing -> Nothing+    Just (CustomClaim _ v) -> Just v+    Just _ -> error "impossible: invalid claim for key"++-- | Whether a collection of claims is empty.+null :: Claims -> Bool+null = Map.null . unClaims++-- | Size of a collection of claims.+size :: Claims -> Int+size = Map.size . unClaims++------------------------------------------------------------------------------+-- Conversion+------------------------------------------------------------------------------++-- | Convert a collection of 'Claims' to a list of 'Claim's.+toList :: Claims -> [Claim]+toList = Map.elems . unClaims++-- | Convert a list of 'Claim's to a collection of 'Claims'.+--+-- Note that if the provided list contains more than one value for the same+-- claim, the last value for that claim is retained.+fromList :: [Claim] -> Claims+fromList = Claims . Map.fromList . map (\c -> (claimKey c, c))
+ src/Crypto/Paseto/Token/Encoding.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++-- | PASETO token encoding and decoding in accordance with the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+module Crypto.Paseto.Token.Encoding+  ( -- * Encoding+    encode+  , encodeSomeToken++    -- * Decoding+  , CommonDecodingError (..)+  , renderCommonDecodingError+  , V3LocalDecodingError (..)+  , renderV3LocalDecodingError+  , decodeTokenV3Local+  , V3PublicDecodingError (..)+  , renderV3PublicDecodingError+  , decodeTokenV3Public+  , V4LocalDecodingError (..)+  , renderV4LocalDecodingError+  , decodeTokenV4Local+  , V4PublicDecodingError (..)+  , renderV4PublicDecodingError+  , decodeTokenV4Public++    -- * Validated token+  , ValidatedToken (..)+  ) where++import Crypto.Paseto.Keys ( SymmetricKey (..), VerificationKey (..) )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import qualified Crypto.Paseto.Protocol.V3 as V3+import qualified Crypto.Paseto.Protocol.V4 as V4+import Crypto.Paseto.Token+  ( Footer (..), ImplicitAssertion, Payload (..), SomeToken (..), Token (..) )+import Crypto.Paseto.Token.Claims ( Claims )+import Crypto.Paseto.Token.Parser+  ( parseTokenV3Local+  , parseTokenV3Public+  , parseTokenV4Local+  , parseTokenV4Public+  )+import Crypto.Paseto.Token.Validation+  ( ValidationError, ValidationRule, renderValidationErrors, validate )+import Data.Bifunctor ( first )+import qualified Data.ByteString.Base64.URL as B64URL+import Data.List.NonEmpty ( NonEmpty )+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Text.Encoding ( decodeUtf8 )+import Prelude+import Text.Parsec ( ParseError )++-- | Encode a PASETO token as human-readable text according to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+encode :: Token v p -> Text+encode t =+  case t of+    TokenV3Local (Payload payload) mbFooter ->+      decodeUtf8 V3.v3LocalTokenHeader+        <> decodeUtf8 (B64URL.encodeUnpadded payload)+        <> case mbFooter of+          Nothing -> ""+          Just (Footer footer) -> "." <> decodeUtf8 (B64URL.encodeUnpadded footer)+    TokenV3Public (Payload payload) mbFooter ->+      decodeUtf8 V3.v3PublicTokenHeader+        <> decodeUtf8 (B64URL.encodeUnpadded payload)+        <> case mbFooter of+          Nothing -> ""+          Just (Footer footer) -> "." <> decodeUtf8 (B64URL.encodeUnpadded footer)+    TokenV4Local (Payload payload) mbFooter ->+      decodeUtf8 V4.v4LocalTokenHeader+        <> decodeUtf8 (B64URL.encodeUnpadded payload)+        <> case mbFooter of+          Nothing -> ""+          Just (Footer footer) -> "." <> decodeUtf8 (B64URL.encodeUnpadded footer)+    TokenV4Public (Payload payload) mbFooter ->+      decodeUtf8 V4.v4PublicTokenHeader+        <> decodeUtf8 (B64URL.encodeUnpadded payload)+        <> case mbFooter of+          Nothing -> ""+          Just (Footer footer) -> "." <> decodeUtf8 (B64URL.encodeUnpadded footer)++-- | Encode a PASETO token as human-readable text according to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+encodeSomeToken :: SomeToken -> Text+encodeSomeToken t =+  case t of+    SomeTokenV3Local x -> encode x+    SomeTokenV3Public x -> encode x+    SomeTokenV4Local x -> encode x+    SomeTokenV4Public x -> encode x++-- | PASETO token which has been decoded and validated.+data ValidatedToken v p = ValidatedToken+  { -- | Validated token.+    vtToken :: !(Token v p)+  , -- | Validated token's claims.+    vtClaims :: !Claims+  } deriving stock (Show, Eq)++-- | Common error decoding a PASETO token.+data CommonDecodingError+  = -- | Error parsing the token.+    CommonDecodingParseError !ParseError+  | -- | Token claims validation error.+    CommonDecodingClaimsValidationError !(NonEmpty ValidationError)+  deriving stock (Show, Eq)++-- | Render a 'CommonDecodingError' as 'Text'.+renderCommonDecodingError :: CommonDecodingError -> Text+renderCommonDecodingError err =+  case err of+    CommonDecodingParseError e -> T.pack (show e)+    CommonDecodingClaimsValidationError e -> renderValidationErrors e++assertValid :: [ValidationRule] -> Claims -> Either CommonDecodingError ()+assertValid rs cs =+  case validate rs cs of+    Left err -> Left (CommonDecodingClaimsValidationError err)+    Right _ -> Right ()++-- | Error decoding a version 3 local PASETO token.+data V3LocalDecodingError+  = -- | Common decoding error.+    V3LocalDecodingCommonError !CommonDecodingError+  | -- | Decryption error.+    V3LocalDecodingDecryptionError !V3.DecryptionError+  deriving stock (Show, Eq)++-- | Render a 'V3LocalDecodingError' as 'Text'.+renderV3LocalDecodingError :: V3LocalDecodingError -> Text+renderV3LocalDecodingError err =+  case err of+    V3LocalDecodingCommonError e -> renderCommonDecodingError e+    V3LocalDecodingDecryptionError e -> V3.renderDecryptionError e++-- | Parse, 'V3.decrypt', and 'validate' a version 3 local PASETO token.+decodeTokenV3Local+  :: SymmetricKey V3+  -- ^ Symmetric key.+  -> [ValidationRule]+  -- ^ Validation rules.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Text+  -- ^ Encoded PASETO token.+  -> Either V3LocalDecodingError (ValidatedToken V3 Local)+decodeTokenV3Local k rs f i t = do+  parsed <-+    first+      (V3LocalDecodingCommonError . CommonDecodingParseError)+      (parseTokenV3Local t)+  claims <-+    case V3.decrypt k parsed f i of+      Left err -> Left (V3LocalDecodingDecryptionError err)+      Right x -> Right x+  first V3LocalDecodingCommonError (assertValid rs claims)+  Right ValidatedToken+    { vtToken = parsed+    , vtClaims = claims+    }++-- | Error decoding a version 3 public PASETO token.+data V3PublicDecodingError+  = -- | Common decoding error.+    V3PublicDecodingCommonError !CommonDecodingError+  | -- | Cryptographic signature verification error.+    V3PublicDecodingVerificationError !V3.VerificationError+  deriving stock (Show, Eq)++-- | Render a 'V3PublicDecodingError' as 'Text'.+renderV3PublicDecodingError :: V3PublicDecodingError -> Text+renderV3PublicDecodingError err =+  case err of+    V3PublicDecodingCommonError e -> renderCommonDecodingError e+    V3PublicDecodingVerificationError e -> V3.renderVerificationError e++-- | Parse, 'V3.verify', and 'validate' a version 3 public PASETO token.+decodeTokenV3Public+  :: VerificationKey V3+  -- ^ Verification key.+  -> [ValidationRule]+  -- ^ Validation rules.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Text+  -- ^ Encoded PASETO token.+  -> Either V3PublicDecodingError (ValidatedToken V3 Public)+decodeTokenV3Public vk rs f i t = do+  parsed <-+    first+      (V3PublicDecodingCommonError . CommonDecodingParseError)+      (parseTokenV3Public t)+  claims <-+    case V3.verify vk parsed f i of+      Left err -> Left (V3PublicDecodingVerificationError err)+      Right x -> Right x+  first V3PublicDecodingCommonError (assertValid rs claims)+  Right ValidatedToken+    { vtToken = parsed+    , vtClaims = claims+    }++-- | Error decoding a version 4 local PASETO token.+data V4LocalDecodingError+  = -- | Common decoding error.+    V4LocalDecodingCommonError !CommonDecodingError+  | -- | Decryption error.+    V4LocalDecodingDecryptionError !V4.DecryptionError+  deriving stock (Show, Eq)++-- | Render a 'V4LocalDecodingError' as 'Text'.+renderV4LocalDecodingError :: V4LocalDecodingError -> Text+renderV4LocalDecodingError err =+  case err of+    V4LocalDecodingCommonError e -> renderCommonDecodingError e+    V4LocalDecodingDecryptionError e -> V4.renderDecryptionError e++-- | Parse, 'V4.decrypt', and 'validate' a version 4 local PASETO token.+decodeTokenV4Local+  :: SymmetricKey V4+  -- ^ Symmetric key.+  -> [ValidationRule]+  -- ^ Validation rules.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Text+  -- ^ Encoded PASETO token.+  -> Either V4LocalDecodingError (ValidatedToken V4 Local)+decodeTokenV4Local k rs f i t = do+  parsed <-+    first+      (V4LocalDecodingCommonError . CommonDecodingParseError)+      (parseTokenV4Local t)+  claims <-+    case V4.decrypt k parsed f i of+      Left err -> Left (V4LocalDecodingDecryptionError err)+      Right x -> Right x+  first V4LocalDecodingCommonError (assertValid rs claims)+  Right ValidatedToken+    { vtToken = parsed+    , vtClaims = claims+    }++-- | Error decoding a version 4 public PASETO token.+data V4PublicDecodingError+  = -- | Common decoding error.+    V4PublicDecodingCommonError !CommonDecodingError+  | -- | Cryptographic signature verification error.+    V4PublicDecodingVerificationError !V4.VerificationError+  deriving stock (Show, Eq)++-- | Render a 'V4PublicDecodingError' as 'Text'.+renderV4PublicDecodingError :: V4PublicDecodingError -> Text+renderV4PublicDecodingError err =+  case err of+    V4PublicDecodingCommonError e -> renderCommonDecodingError e+    V4PublicDecodingVerificationError e -> V4.renderVerificationError e++-- | Parse, 'V4.verify', and 'validate' a version 4 public PASETO token.+decodeTokenV4Public+  :: VerificationKey V4+  -- ^ Verification key.+  -> [ValidationRule]+  -- ^ Validation rules.+  -> Maybe Footer+  -- ^ Optional footer to authenticate.+  -> Maybe ImplicitAssertion+  -- ^ Optional implicit assertion to authenticate.+  -> Text+  -- ^ Encoded PASETO token.+  -> Either V4PublicDecodingError (ValidatedToken V4 Public)+decodeTokenV4Public vk rs f i t = do+  parsed <-+    first+      (V4PublicDecodingCommonError . CommonDecodingParseError)+      (parseTokenV4Public t)+  claims <-+    case V4.verify vk parsed f i of+      Left err -> Left (V4PublicDecodingVerificationError err)+      Right x -> Right x+  first V4PublicDecodingCommonError (assertValid rs claims)+  Right ValidatedToken+    { vtToken = parsed+    , vtClaims = claims+    }
+ src/Crypto/Paseto/Token/Parser.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Parsers for PASETO tokens according to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that the parsers exported from this module /do not/ perform any kind+-- of token validation, cryptographic or otherwise. These parsers simply+-- ensure that the input /looks like/ a well-formed token.+module Crypto.Paseto.Token.Parser+  ( -- * Token parsers+    parseTokenV3Local+  , parseTokenV3Public+  , parseTokenV4Local+  , parseTokenV4Public+  , parseSomeToken++    -- ** Parsec parsers+  , pVersion+  , pVersionV3+  , pVersionV4+  , pPurpose+  , pPurposeLocal+  , pPurposePublic+  , pPayload+  , pFooter+  , pPayloadAndFooter+  , pTokenParts+  , pTokenV3Local+  , pTokenV3Public+  , pTokenV4Local+  , pTokenV4Public+  , pSomeToken+  ) where++import Control.Applicative ( some, (<|>) )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Crypto.Paseto.Token+  ( Footer (..), Payload (..), SomeToken (..), Token (..) )+import qualified Data.ByteString.Base64.URL as B64URL+import qualified Data.ByteString.Char8 as B8+import Data.Char ( isAsciiLower, isAsciiUpper, isDigit )+import Data.Functor ( void, ($>) )+import Data.Maybe ( isJust )+import Data.Text ( Text )+import Prelude+import Text.Parsec+  ( ParseError+  , ParsecT+  , Stream+  , char+  , eof+  , optionMaybe+  , parse+  , satisfy+  , string+  , try+  , (<?>)+  )+import Text.Parsec.Text ( Parser )++-- | Parse a version 3 local PASETO token from human-readable text according+-- to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that this function does not perform any kind of token validation,+-- cryptographic or otherwise. It simply parses the token and ensures that it+-- is well-formed.+parseTokenV3Local :: Text -> Either ParseError (Token V3 Local)+parseTokenV3Local = parse pTokenV3Local ""++-- | Parse a version 3 public PASETO token from human-readable text according+-- to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that this function does not perform any kind of token validation,+-- cryptographic or otherwise. It simply parses the token and ensures that it+-- is well-formed.+parseTokenV3Public :: Text -> Either ParseError (Token V3 Public)+parseTokenV3Public = parse pTokenV3Public ""++-- | Parse a version 4 local PASETO token from human-readable text according+-- to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that this function does not perform any kind of token validation,+-- cryptographic or otherwise. It simply parses the token and ensures that it+-- is well-formed.+parseTokenV4Local :: Text -> Either ParseError (Token V4 Local)+parseTokenV4Local = parse pTokenV4Local ""++-- | Parse a version 4 public PASETO token from human-readable text according+-- to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that this function does not perform any kind of token validation,+-- cryptographic or otherwise. It simply parses the token and ensures that it+-- is well-formed.+parseTokenV4Public :: Text -> Either ParseError (Token V4 Public)+parseTokenV4Public = parse pTokenV4Public ""++-- | Parse some kind of PASETO token from human-readable text according to the+-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)+-- defined in the specification.+--+-- Note that this function does not perform any kind of token validation,+-- cryptographic or otherwise. It simply parses the token and ensures that it+-- is well-formed.+parseSomeToken :: Text -> Either ParseError SomeToken+parseSomeToken = parse pSomeToken ""++------------------------------------------------------------------------------+-- Parsec parsers+------------------------------------------------------------------------------++-- | Parse a valid @base64url@ character.+base64urlChar :: Stream s m Char => ParsecT s u m Char+base64urlChar = satisfy (\c -> isAsciiUpper c || isAsciiLower c || isDigit c || c == '-' || c == '_') <?> "base64url character"++-- | Period (\".\") parser.+period :: Parser ()+period = void $ char '.'++-- | Parse a 'Version' from its string representation.+pVersion :: Parser Version+pVersion =+  try pVersionV3+    <|> pVersionV4+    <?> "version"++-- | Parse the 'Version' string @v3@.+pVersionV3 :: Parser Version+pVersionV3 = string "v3" $> V3++-- | Parse the 'Version' string @v4@.+pVersionV4 :: Parser Version+pVersionV4 = string "v4" $> V4++-- | Parse a 'Purpose' from its string representation.+pPurpose :: Parser Purpose+pPurpose =+  try pPurposeLocal+    <|> pPurposePublic+    <?> "purpose"++-- | Parse the 'Purpose' string @local@.+pPurposeLocal :: Parser Purpose+pPurposeLocal = string "local" $> Local++-- | Parse the 'Purpose' string @public@.+pPurposePublic :: Parser Purpose+pPurposePublic = string "public" $> Public++-- | Parse a 'Payload' from its string representation.+pPayload :: Parser Payload+pPayload = do+  payloadB64 <- B8.pack <$> some base64urlChar+  case B64URL.decodeUnpadded payloadB64 of+    Left err -> fail err+    Right x -> pure (Payload x)++-- | Parse a 'Footer' from its string representation.+pFooter :: Parser Footer+pFooter = do+  footerB64 <- B8.pack <$> some base64urlChar+  case B64URL.decodeUnpadded footerB64 of+    Left err -> fail err+    Right x -> pure (Footer x)++-- | Parse a 'Payload' along with an optional 'Footer'.+pPayloadAndFooter :: Parser (Payload, Maybe Footer)+pPayloadAndFooter = do+  payload <- pPayload <?> "payload"+  hasFooter <- isJust <$> optionMaybe period+  case hasFooter of+    False -> do+      eof+      pure (payload, Nothing)+    True -> do+      footer <- pFooter <?> "footer"+      eof+      pure (payload, Just footer)++-- | Parse the parts of a PASETO token: version, purpose, payload, and an+-- optional footer.+pTokenParts+  :: Parser Version+  -- ^ Parser for the 'Version' part of a token.+  -> Parser Purpose+  -- ^ Parser for the 'Purpose' part of a token.+  -> Parser (Version, Purpose, Payload, Maybe Footer)+pTokenParts pV pP = do+  version <- pV+  period+  purpose <- pP+  period+  (payload, mbFooter) <- pPayloadAndFooter+  pure (version, purpose, payload, mbFooter)++-- | Parse a version 3 local PASETO token from its string representation.+--+-- Accepted token format:+--+-- * Without the optional footer: @v3.local.${payload}@+--+-- * With the optional footer: @v3.local.${payload}.${footer}@+--+-- Both the @payload@ and optional @footer@ are @base64url@-encoded values+-- (unpadded).+pTokenV3Local :: Parser (Token V3 Local)+pTokenV3Local = do+  (_, _, payload, mbFooter) <- pTokenParts pVersionV3 pPurposeLocal+  pure (TokenV3Local payload mbFooter)++-- | Parse a version 3 public PASETO token from its string representation.+--+-- Accepted token format:+--+-- * Without the optional footer: @v3.public.${payload}@+--+-- * With the optional footer: @v3.public.${payload}.${footer}@+--+-- Both the @payload@ and optional @footer@ are @base64url@-encoded values+-- (unpadded).+pTokenV3Public :: Parser (Token V3 Public)+pTokenV3Public = do+  (_, _, payload, mbFooter) <- pTokenParts pVersionV3 pPurposePublic+  pure (TokenV3Public payload mbFooter)++-- | Parse a version 4 local PASETO token from its string representation.+--+-- Accepted token format:+--+-- * Without the optional footer: @v4.local.${payload}@+--+-- * With the optional footer: @v4.local.${payload}.${footer}@+--+-- Both the @payload@ and optional @footer@ are @base64url@-encoded values+-- (unpadded).+pTokenV4Local :: Parser (Token V4 Local)+pTokenV4Local = do+  (_, _, payload, mbFooter) <- pTokenParts pVersionV4 pPurposeLocal+  pure (TokenV4Local payload mbFooter)++-- | Parse a version 4 public PASETO token from its string representation.+--+-- Accepted token format:+--+-- * Without the optional footer: @v4.public.${payload}@+--+-- * With the optional footer: @v4.public.${payload}.${footer}@+--+-- Both the @payload@ and optional @footer@ are @base64url@-encoded values+-- (unpadded).+pTokenV4Public :: Parser (Token V4 Public)+pTokenV4Public = do+  (_, _, payload, mbFooter) <- pTokenParts pVersionV4 pPurposePublic+  pure (TokenV4Public payload mbFooter)++-- | Parse some kind of PASETO token from its string representation.+--+-- PASETO token format:+--+-- * Without the optional footer: @version.purpose.payload@+--+-- * With the optional footer: @version.purpose.payload.footer@+--+-- Acceptable values for @version@ are @v3@ and @v4@. @v1@ and @v2@ are+-- deprecated, so they're not supported.+--+-- Acceptable values for @purpose@ are @local@ and @public@.+--+-- Both the @payload@ and optional @footer@ are @base64url@-encoded values+-- (unpadded).+pSomeToken :: Parser SomeToken+pSomeToken = do+  (version, purpose, payload, mbFooter) <- pTokenParts pVersion pPurpose+  pure (mkToken version purpose payload mbFooter)+  where+    mkToken :: Version -> Purpose -> Payload -> Maybe Footer -> SomeToken+    mkToken version purpose payload mbFooter =+      case (version, purpose) of+        (V3, Local) -> SomeTokenV3Local (TokenV3Local payload mbFooter)+        (V3, Public) -> SomeTokenV3Public (TokenV3Public payload mbFooter)+        (V4, Local) -> SomeTokenV4Local (TokenV4Local payload mbFooter)+        (V4, Public) -> SomeTokenV4Public (TokenV4Public payload mbFooter)
+ src/Crypto/Paseto/Token/Validation.hs view
@@ -0,0 +1,247 @@+-- | PASETO token claim validation.+module Crypto.Paseto.Token.Validation+  ( -- * Errors+    ValidationError (..)+  , renderValidationError+  , renderValidationErrors++    -- * Rules+  , ValidationRule (..)+  , ClaimMustExist (..)+    -- ** Simple rules+  , forAudience+  , identifiedBy+  , issuedBy+  , notExpired+  , subject+  , validAt+  , customClaimEq+    -- ** Recommended default rules+  , getDefaultValidationRules++    -- * Validation+  , validate+  , validateDefault+  ) where++import Crypto.Paseto.Token.Claim+  ( Audience (..)+  , ClaimKey (..)+  , Expiration (..)+  , IssuedAt (..)+  , Issuer (..)+  , NotBefore (..)+  , Subject (..)+  , TokenIdentifier (..)+  , UnregisteredClaimKey+  , renderClaimKey+  , renderExpiration+  , renderIssuedAt+  , renderNotBefore+  )+import Crypto.Paseto.Token.Claims+  ( Claims+  , lookupAudience+  , lookupCustom+  , lookupExpiration+  , lookupIssuedAt+  , lookupIssuer+  , lookupNotBefore+  , lookupSubject+  , lookupTokenIdentifier+  )+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import Data.Either ( lefts )+import qualified Data.List as L+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time.Clock ( UTCTime, getCurrentTime )+import Prelude hiding ( exp, lookup )++-- | Validation error.+data ValidationError+  = -- | Expected claim does not exist.+    ValidationClaimNotFoundError+      -- | Claim key which could not be found.+      !ClaimKey+  | -- | Token claim is invalid.+    ValidationInvalidClaimError+      -- | Claim key.+      !ClaimKey+      -- | Expected claim value (rendered as 'Text').+      !Text+      -- | Actual claim value (rendered as 'Text').+      !Text+  | -- | Token is expired.+    ValidationExpirationError !Expiration+  | -- | Token's 'IssuedAt' time is in the future.+    ValidationIssuedAtError !IssuedAt+  | -- | Token is not yet valid as its 'NotBefore' time is in the future.+    ValidationNotBeforeError !NotBefore+  | -- | Custom validation error.+    ValidationCustomError !Text+  deriving stock (Show, Eq)++-- | Render a 'ValidationError' as 'Text'.+renderValidationError :: ValidationError -> Text+renderValidationError err =+  case err of+    ValidationClaimNotFoundError k ->+      "\"" <> renderClaimKey k <> "\" claim does not exist"+    ValidationInvalidClaimError k expected actual ->+      "expected value \""+        <> expected+        <> "\" for \""+        <> renderClaimKey k+        <> "\" claim but encountered \""+        <> actual+        <> "\""+    ValidationExpirationError exp ->+      "token expired at " <> renderExpiration exp+    ValidationIssuedAtError iat ->+      "token is not issued until " <> renderIssuedAt iat+    ValidationNotBeforeError nbf ->+      "token is not valid before " <> renderNotBefore nbf+    ValidationCustomError e -> e++-- | Render a non-empty list of 'ValidationError's as 'Text'.+renderValidationErrors :: NonEmpty ValidationError -> Text+renderValidationErrors errs =+  T.intercalate ", " (map renderValidationError (NE.toList errs))++-- | Token claim validation rule.+newtype ValidationRule = ValidationRule+  { unValidationRule :: Claims -> Either ValidationError () }++-- | Whether a claim must exist.+newtype ClaimMustExist = ClaimMustExist Bool++-- | Build a simple validation rule which checks whether a value extracted+-- from the 'Claims' is equal to a given expected value.+mkEqValidationRule+  :: Eq a+  => (Claims -> Maybe a)+  -- ^ Extract a value from the claims (i.e. the actual value).+  -> ClaimKey+  -- ^ Claim key which corresponds to the extracted value (this is used in+  -- constructing errors).+  -> (a -> Text)+  -- ^ Render the expected value as 'Text' (this is used in constructing+  -- errors).+  -> a+  -- ^ Expected value.+  -> ValidationRule+mkEqValidationRule lookup claimKey render x = ValidationRule $ \cs ->+  case lookup cs of+    Just y+      | x == y -> Right ()+      | otherwise -> Left $ ValidationInvalidClaimError claimKey (render x) (render y)+    Nothing -> Left (ValidationClaimNotFoundError claimKey)++-- | Validate that a token is intended for a given audience.+forAudience :: Audience -> ValidationRule+forAudience = mkEqValidationRule lookupAudience AudienceClaimKey unAudience++-- | Validate a token's identifier.+identifiedBy :: TokenIdentifier -> ValidationRule+identifiedBy = mkEqValidationRule lookupTokenIdentifier TokenIdentifierClaimKey unTokenIdentifier++-- | Validate a token's issuer.+issuedBy :: Issuer -> ValidationRule+issuedBy = mkEqValidationRule lookupIssuer IssuerClaimKey unIssuer++-- | Validate that a token is not expired at the given time.+--+-- That is, if the 'Crypto.Paseto.Token.Claim.ExpirationClaim' is present,+-- check that it isn't in the past (relative to the given time).+notExpired :: UTCTime -> ValidationRule+notExpired x = ValidationRule $ \cs ->+  case lookupExpiration cs of+    Just exp@(Expiration y)+      | x <= y -> Right ()+      | otherwise -> Left (ValidationExpirationError exp)+    Nothing -> Right ()++-- | Validate the subject of a token.+subject :: Subject -> ValidationRule+subject = mkEqValidationRule lookupSubject SubjectClaimKey unSubject++-- | Validate that a token is valid at the given time.+--+-- This involves the following checks (relative to the given time):+--+-- * If the 'Crypto.Paseto.Token.Claim.ExpirationClaim' is present, check that+-- it isn't in the past.+--+-- * If the 'Crypto.Paseto.Token.Claim.IssuedAtClaim' is present, check that it+-- isn't in the future.+--+-- * If the 'Crypto.Paseto.Token.Claim.NotBeforeClaim' is present, check that+-- it isn't in the future.+validAt :: UTCTime -> ValidationRule+validAt x = ValidationRule $ \cs -> do+  unValidationRule (notExpired x) cs++  case lookupIssuedAt cs of+    Nothing -> Right ()+    Just iat@(IssuedAt y)+      | x >= y -> Right ()+      | otherwise -> Left (ValidationIssuedAtError iat)++  case lookupNotBefore cs of+    Nothing -> Right ()+    Just nbf@(NotBefore y)+      | x >= y -> Right ()+      | otherwise -> Left (ValidationNotBeforeError nbf)++-- | Validate that a custom claim is equal to the given value.+customClaimEq+  :: ClaimMustExist+  -- ^ Whether the custom claim must exist.+  -> UnregisteredClaimKey+  -- ^ Custom claim key to lookup.+  -> Aeson.Value+  -- ^ Custom claim value to validate (i.e. the expected value).+  -> ValidationRule+customClaimEq mustExist k expected = ValidationRule $ \cs ->+  case (mustExist, lookupCustom k cs) of+    (ClaimMustExist True, Nothing) -> Left (ValidationClaimNotFoundError $ CustomClaimKey k)+    (ClaimMustExist False, Nothing) -> Right ()+    (_, Just actual)+      | expected == actual -> Right ()+      | otherwise ->+          Left $+            ValidationInvalidClaimError+              (CustomClaimKey k)+              (TE.decodeUtf8 . BS.toStrict $ Aeson.encode expected)+              (TE.decodeUtf8 . BS.toStrict $ Aeson.encode actual)++-- | Get a list of+-- [recommended default validation rules](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/02-Implementation-Guide/05-API-UX.md#secure-defaults).+--+-- At the moment, the only default rule is checking 'validAt' for the current+-- system time ('getCurrentTime').+getDefaultValidationRules :: IO [ValidationRule]+getDefaultValidationRules = L.singleton . validAt <$> getCurrentTime++-- | Validate a list of rules against a collection of claims.+--+-- This function will run through all of the provided validation rules and+-- collect all of the errors encountered, if any. If there are no validation+-- errors, @Right ()@ is returned.+validate :: [ValidationRule] -> Claims -> Either (NonEmpty ValidationError) ()+validate rs cs =+  case NE.nonEmpty $ lefts (map v rs) of+    Just errs -> Left errs+    Nothing -> Right ()+  where+    v (ValidationRule f) = f cs++-- | Validate a collection of claims against the default validation rules+-- ('getDefaultValidationRules').+validateDefault :: Claims -> IO (Either (NonEmpty ValidationError) ())+validateDefault cs = flip validate cs <$> getDefaultValidationRules
+ src/Data/Binary/Put/Integer.hs view
@@ -0,0 +1,27 @@+module Data.Binary.Put.Integer+  ( putIntegerbe+  ) where++import Data.Binary.Put ( Put, putByteString )+import Data.Bits ( shiftR )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import Data.Word ( Word8 )+import Prelude++-- | Encode an 'Integer' to a 'ByteString' as big endian.+--+-- Ripped from [haskoin-core-1.1.0](https://hackage.haskell.org/package/haskoin-core-1.1.0/docs/src/Haskoin.Util.Helpers.html#integerToBS).+integerToBS :: Integer -> ByteString+integerToBS 0 = BS.pack [0]+integerToBS i+  | i > 0 = BS.reverse $ BS.unfoldr f i+  | otherwise = error "integerToBS not defined for negative values"+  where+    f 0 = Nothing+    f x = Just (fromInteger x :: Word8, x `shiftR` 8)++-- | Write an 'Integer' in big endian format+putIntegerbe :: Integer -> Put+putIntegerbe = putByteString . integerToBS+{-# INLINE putIntegerbe #-}
+ test/Main.hs view
@@ -0,0 +1,27 @@+module Main where++import Hedgehog.Main ( defaultMain )+import Prelude+import qualified Test.Crypto.Paseto.Keys.V3+import qualified Test.Crypto.Paseto.PreAuthenticationEncoding+import qualified Test.Crypto.Paseto.Protocol.V3+import qualified Test.Crypto.Paseto.Protocol.V4+import qualified Test.Crypto.Paseto.TestVectorTest+import qualified Test.Crypto.Paseto.Token.Claim+import qualified Test.Crypto.Paseto.Token.Claims+import qualified Test.Crypto.Paseto.Token.Parser+import qualified Test.Crypto.Paseto.Token.Validation++main :: IO ()+main =+  defaultMain+    [ Test.Crypto.Paseto.Keys.V3.tests+    , Test.Crypto.Paseto.PreAuthenticationEncoding.tests+    , Test.Crypto.Paseto.Protocol.V3.tests+    , Test.Crypto.Paseto.Protocol.V4.tests+    , Test.Crypto.Paseto.TestVectorTest.tests+    , Test.Crypto.Paseto.Token.Claim.tests+    , Test.Crypto.Paseto.Token.Claims.tests+    , Test.Crypto.Paseto.Token.Parser.tests+    , Test.Crypto.Paseto.Token.Validation.tests+    ]
+ test/Test/Crypto/Paseto/Keys/Gen.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds #-}++module Test.Crypto.Paseto.Keys.Gen+  ( genSymmetricKeyV3+  , genSigningKeyV3+  , genSymmetricKeyV4+  , genSigningKeyV4+  ) where++import qualified Crypto.Error as Crypto+import Crypto.Paseto.Keys ( SigningKey (..), SymmetricKey (..) )+import Crypto.Paseto.Mode ( Version (..) )+import qualified Crypto.PubKey.Ed25519 as Crypto.Ed25519+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Crypto.Paseto.Keys.V3.Gen ( genPrivateKeyP384 )+import Test.Crypto.Paseto.ScrubbedBytes.Gen ( genScrubbedBytes32 )++genSymmetricKeyV3 :: Gen (SymmetricKey V3)+genSymmetricKeyV3 =+  SymmetricKeyV3 <$> genScrubbedBytes32++genSigningKeyV3 :: Gen (SigningKey V3)+genSigningKeyV3 =+  SigningKeyV3 <$> genPrivateKeyP384++genSymmetricKeyV4 :: Gen (SymmetricKey V4)+genSymmetricKeyV4 =+  SymmetricKeyV4 <$> genScrubbedBytes32++genSigningKeyV4 :: Gen (SigningKey V4)+genSigningKeyV4 = do+  bs <- Gen.bytes (Range.singleton 32)+  case Crypto.eitherCryptoError (Crypto.Ed25519.secretKey bs) of+    Left err -> fail $ "could not generate a secret key: " <> show err+    Right x -> pure (SigningKeyV4 x)
+ test/Test/Crypto/Paseto/Keys/V3.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Keys.V3+  ( tests+  ) where++import Crypto.Paseto.Keys.V3+  ( decodePrivateKeyP384+  , decodePublicKeyP384+  , encodePrivateKeyP384+  , encodePublicKeyP384+  )+import Hedgehog+  ( Property, checkParallel, discover, forAll, property, tripping )+import Prelude+import Test.Crypto.Paseto.Keys.V3.Gen ( genKeyPairP384 )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'encodePrivateKeyP384' and 'decodePrivateKeyP384' round trip.+prop_roundTrip_encodeDecodePrivateKeyP384 :: Property+prop_roundTrip_encodeDecodePrivateKeyP384 = property $ do+  (_, privKey) <- forAll genKeyPairP384+  tripping privKey encodePrivateKeyP384 decodePrivateKeyP384++-- | Test that 'encodePublicKeyP384' and 'decodePublicKeyP384' round trip.+prop_roundTrip_encodeDecodePublicKeyP384 :: Property+prop_roundTrip_encodeDecodePublicKeyP384 = property $ do+  (pubKey, _) <- forAll genKeyPairP384+  tripping pubKey encodePublicKeyP384 decodePublicKeyP384
+ test/Test/Crypto/Paseto/Keys/V3/Gen.hs view
@@ -0,0 +1,41 @@+module Test.Crypto.Paseto.Keys.V3.Gen+  ( genScalarP384+  , genPrivateKeyP384+  , genKeyPairP384+  ) where++import Crypto.Paseto.Keys.V3+  ( PrivateKeyP384+  , PublicKeyP384+  , curveP384+  , fromPrivateKeyP384+  , isScalarValidP384+  , mkPrivateKeyP384+  )+import qualified Crypto.PubKey.ECC.ECDSA as Crypto+import qualified Crypto.PubKey.ECC.Types as Crypto+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude++-- | Generate a valid scalar value for curve P384.+genScalarP384 :: Gen Integer+genScalarP384 =+  Gen.filter isScalarValidP384 (Gen.integral (Range.constant 1 (n - 1)))+  where+    n :: Integer+    n = Crypto.ecc_n (Crypto.common_curve curveP384)++-- | Generate a 'PrivateKeyP384'.+genPrivateKeyP384 :: Gen PrivateKeyP384+genPrivateKeyP384 = do+  s <- genScalarP384+  case mkPrivateKeyP384 (Crypto.PrivateKey curveP384 s) of+    Nothing -> fail "Failed to generate a scalar value"+    Just x -> pure x++genKeyPairP384 :: Gen (PublicKeyP384, PrivateKeyP384)+genKeyPairP384 = toKeyPair <$> genPrivateKeyP384+  where+    toKeyPair privateKey = (fromPrivateKeyP384 privateKey, privateKey)
+ test/Test/Crypto/Paseto/PreAuthenticationEncoding.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.PreAuthenticationEncoding+  ( tests+  ) where++import Crypto.Paseto.PreAuthenticationEncoding ( decode, encode )+import Data.ByteString ( ByteString )+import Hedgehog+  ( Gen, Property, checkParallel, discover, forAll, property, tripping )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Golden ( goldenTestPae )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'encode' and 'decode' round trip.+prop_roundTrip_encodeDecode :: Property+prop_roundTrip_encodeDecode = property $ do+  pieces <- forAll genPieces+  tripping pieces encode decode++prop_golden_example1 :: Property+prop_golden_example1 = goldenTestPae goldenExample1 "test/golden/pae/example1/golden.bin"++prop_golden_example2 :: Property+prop_golden_example2 = goldenTestPae goldenExample2 "test/golden/pae/example2/golden.bin"++prop_golden_example3 :: Property+prop_golden_example3 = goldenTestPae goldenExample3 "test/golden/pae/example3/golden.bin"++prop_golden_example4 :: Property+prop_golden_example4 = goldenTestPae goldenExample4 "test/golden/pae/example4/golden.bin"++------------------------------------------------------------------------------+-- Generators+------------------------------------------------------------------------------++genPieces :: Gen [ByteString]+genPieces = Gen.list (Range.constant 0 256) $ Gen.bytes (Range.constant 0 256)++------------------------------------------------------------------------------+-- Golden examples+------------------------------------------------------------------------------++goldenExample1 :: [ByteString]+goldenExample1 = []++goldenExample2 :: [ByteString]+goldenExample2 = [""]++goldenExample3 :: [ByteString]+goldenExample3 = ["test"]++goldenExample4 :: [ByteString]+goldenExample4 =+  [ "test"+  , "1337"+  , "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"+  , ""+  , "\0\0\0\0\0\0\0\0\0\0\0aaaaaaaa\0\0\0\0\0\0\0\0\0\0\0aa\0\0\0bbbb\0\0aa31337"+  , "The quick brown fox jumps over the lazy dog"+  , "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Phasellus sit amet fringilla tellus. Nunc sem magna, tristique non tortor eu, placerat consequat libero. Vivamus sed facilisis tellus. Phasellus aliquam tortor sit amet nisi ultricies tincidunt. In id egestas mauris. Vivamus ullamcorper at erat euismod feugiat. Duis eleifend dui ac mattis imperdiet. Ut faucibus risus eget molestie blandit.\n\nInterdum et malesuada fames ac ante ipsum primis in faucibus. Nullam gravida tempus tortor, id vulputate ex placerat ut. Integer venenatis, mauris non vehicula cursus, est elit porttitor dui, ac tempus mi neque vitae erat. Nulla mi mi, ornare vel molestie sit amet, consequat a odio. Aliquam auctor volutpat nisl eu efficitur. Integer nec facilisis mauris. Etiam blandit risus nisl, et ornare purus blandit quis. Vivamus fermentum commodo nunc nec rutrum.\n\nSed non mi leo. Nam non ligula id nulla rhoncus tempor. Phasellus arcu libero, euismod in ultricies nec, viverra ut diam. Aenean luctus tortor vitae elit laoreet feugiat. Sed tempor ex tincidunt arcu interdum pretium. Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos himenaeos. Nunc eleifend, odio ut dictum ornare, augue ante blandit ligula, ac elementum elit elit at enim. Duis lectus tellus, sodales vel finibus quis, lacinia in lectus. Donec faucibus auctor justo, pharetra convallis dolor sagittis id.\n\nSuspendisse at pulvinar ligula. Suspendisse id lorem ex. Aliquam ac sapien dolor. Suspendisse mattis lectus felis, eu volutpat metus imperdiet nec. Donec luctus porttitor scelerisque. Morbi convallis, felis ut pellentesque posuere, tortor dui imperdiet felis, sit amet pretium nunc neque ac felis. Quisque maximus, ex vel fringilla porta, purus dolor condimentum dui, a pulvinar ante augue vel ante.\n\nVestibulum urna elit, lacinia sed ipsum eget, malesuada mattis erat. Aliquam diam magna, vehicula fermentum ultrices a, malesuada non turpis. Sed interdum lectus sit amet felis porttitor, at rhoncus tortor eleifend. Proin sed gravida lectus, at varius nisi. Nam eu eros eu tortor fermentum maximus. Pellentesque vel diam eu magna sodales luctus vitae non odio. Ut dapibus, urna tincidunt elementum tincidunt, metus mauris lobortis mauris, eget bibendum nisl libero quis turpis. Sed malesuada ex eget porta cursus."+  ]
+ test/Test/Crypto/Paseto/Protocol/V3.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Protocol.V3+  ( tests+  ) where++import Crypto.Paseto.Keys ( SigningKey (..), SymmetricKey (..), fromSigningKey )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Crypto.Paseto.Protocol.V3 ( decrypt, encryptPure, signPure, verify )+import Crypto.Paseto.Token+  ( Footer (..), ImplicitAssertion, Payload (..), Token (..) )+import Crypto.Paseto.Token.Claims ( Claims )+import Data.ByteString ( ByteString )+import Hedgehog+  ( Property, checkParallel, discover, forAll, forAllWith, property, tripping )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Crypto.Paseto.Keys.Gen ( genSigningKeyV3, genSymmetricKeyV3 )+import Test.Crypto.Paseto.Keys.V3.Gen ( genScalarP384 )+import Test.Crypto.Paseto.Token.Claims.Gen ( genClaims )+import Test.Crypto.Paseto.Token.Gen ( genFooter, genImplicitAssertion )+import Test.Golden ( goldenTestPaseto )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'encryptPure' (a pure variant of 'encrypt') and 'decrypt' round+-- trip.+prop_roundTrip_encryptDecrypt :: Property+prop_roundTrip_encryptDecrypt = property $ do+  n <- forAll $ Gen.bytes (Range.singleton 32)+  k <- forAllWith unsafeRenderSymmetricKey genSymmetricKeyV3+  claims <- forAll $ genClaims+  f <- forAll $ Gen.maybe genFooter+  i <- forAll $ Gen.maybe genImplicitAssertion+  tripping claims (\cs -> unsafeEncryptPure n k cs f i) (\t -> decrypt k t f i)+  where+    unsafeEncryptPure+      :: ByteString+      -> SymmetricKey V3+      -> Claims+      -> Maybe Footer+      -> Maybe ImplicitAssertion+      -> Token V3 Local+    unsafeEncryptPure n k cs f i =+      case encryptPure n k cs f i of+        Left err -> error $ "impossible: could not encrypt: " <> show err+        Right encrypted -> encrypted++-- | Test that 'signPure' (a pure variant of 'sign') and 'verify' round trip.+prop_roundTrip_signVerify :: Property+prop_roundTrip_signVerify = property$ do+  k <- forAll genScalarP384+  sk <- forAllWith unsafeRenderSigningKey genSigningKeyV3+  let vk = fromSigningKey sk+  claims <- forAll $ genClaims+  f <- forAll $ Gen.maybe genFooter+  i <- forAll $ Gen.maybe genImplicitAssertion+  tripping claims (\cs -> unsafeSignPure k sk cs f i) (\t -> verify vk t f i)+  where+    unsafeSignPure+      :: Integer+      -> SigningKey V3+      -> Claims+      -> Maybe Footer+      -> Maybe ImplicitAssertion+      -> Token V3 Public+    unsafeSignPure k sk cs f i =+      case signPure k sk cs f i of+        Left err -> error $ "impossible: could not sign: " <> show err+        Right signed -> signed++prop_golden_TokenV3Local :: Property+prop_golden_TokenV3Local = goldenTestPaseto goldenTokenV3Local "test/golden/paseto/v3-local/golden"++prop_golden_TokenV3Public :: Property+prop_golden_TokenV3Public = goldenTestPaseto goldenTokenV3Public "test/golden/paseto/v3-public/golden"++------------------------------------------------------------------------------+-- Golden examples+------------------------------------------------------------------------------++goldenTokenV3Local :: Token V3 Local+goldenTokenV3Local =+  TokenV3Local+    (Payload "&\247U3TH*\GS\145\212xF'\133K\141\166\184\EOT*yfR<+@N\141\187\231\247\242\240c\191/Bp\218\138\223\144\250\200\225\ETB\207\GS\ESC`t_\238\SI\220G1\CANy\252\195\&3\219N\186\142lxr\160\170c\203w0e\f\203v,\DC1\177\209\n\229 \239\151M\191\RS5\138%m\168\168c\SO@\153\146xC)\132E\135\139\vC(\151\237\131\141N\212_\aj\223\188\145\SI6d\128\f\SYN\169\&1\246\174U\145iqfG\189g3\SOHm\189\217\157\250")+    (Just (Footer "{\"kid\":\"UbkK8Y6iv4GZhFp6Tx3IWLWLfNXSEvJcdT3zdR65YZxo\"}"))++goldenTokenV3Public :: Token V3 Public+goldenTokenV3Public =+  TokenV3Public+    (Payload "{\"data\":\"this is a signed message\",\"exp\":\"2022-01-01T00:00:00+00:00\"}\190\182\171OKA>\233\139\177Hy\136\145\131\f~\236\"C\228\213\245\188\DC2>\145\218?\188\140\RS\235\146@\137\200B\177p\195O'\152\203\186\179\239e,\209t\182\254!\175\216\217\133\218\189\142\251\197\178\243%\STXd\ETX\252\227%\230+w\201\150Cn(:\153-\179P\172\179u\218\239\135\&3\254=\192")+    Nothing++------------------------------------------------------------------------------+-- Helpers+------------------------------------------------------------------------------++unsafeRenderSymmetricKey :: SymmetricKey v -> String+unsafeRenderSymmetricKey k =+  case k of+    SymmetricKeyV3 bs -> "SymmetricKeyV3 " <> show bs+    SymmetricKeyV4 bs -> "SymmetricKeyV4 " <> show bs++unsafeRenderSigningKey :: SigningKey v -> String+unsafeRenderSigningKey sk =+  case sk of+    SigningKeyV3 k -> "SigningKeyV3 " <> show k+    SigningKeyV4 bs -> "SigningKeyV4 " <> show bs
+ test/Test/Crypto/Paseto/Protocol/V4.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Protocol.V4+  ( tests+  ) where++import Crypto.Paseto.Keys ( SigningKey (..), SymmetricKey (..), fromSigningKey )+import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Crypto.Paseto.Protocol.V4 ( decrypt, encryptPure, sign, verify )+import Crypto.Paseto.Token ( Footer (..), Payload (..), Token (..) )+import Hedgehog+  ( Property, checkParallel, discover, forAll, forAllWith, property, tripping )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Crypto.Paseto.Keys.Gen ( genSigningKeyV4, genSymmetricKeyV4 )+import Test.Crypto.Paseto.Token.Claims.Gen ( genClaims )+import Test.Crypto.Paseto.Token.Gen ( genFooter, genImplicitAssertion )+import Test.Golden ( goldenTestPaseto )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'encryptPure' (a pure variant of 'encrypt') and 'decrypt' round+-- trip.+prop_roundTrip_encryptDecrypt :: Property+prop_roundTrip_encryptDecrypt = property $ do+  n <- forAll $ Gen.bytes (Range.singleton 32)+  k <- forAllWith unsafeRenderSymmetricKey genSymmetricKeyV4+  claims <- forAll $ genClaims+  f <- forAll $ Gen.maybe genFooter+  i <- forAll $ Gen.maybe genImplicitAssertion+  tripping claims (\cs -> encryptPure n k cs f i) (\t -> decrypt k t f i)++-- | Test that 'signPure' (a pure variant of 'sign') and 'verify' round trip.+prop_roundTrip_signVerify :: Property+prop_roundTrip_signVerify = property $ do+  sk <- forAllWith unsafeRenderSigningKey genSigningKeyV4+  let vk = fromSigningKey sk+  claims <- forAll $ genClaims+  f <- forAll $ Gen.maybe genFooter+  i <- forAll $ Gen.maybe genImplicitAssertion+  tripping claims (\cs -> sign sk cs f i) (\t -> verify vk t f i)++prop_golden_TokenV4Local :: Property+prop_golden_TokenV4Local = goldenTestPaseto goldenTokenV4Local "test/golden/paseto/v4-local/golden"++prop_golden_TokenV4Public :: Property+prop_golden_TokenV4Public = goldenTestPaseto goldenTokenV4Public "test/golden/paseto/v4-public/golden"++------------------------------------------------------------------------------+-- Golden examples+------------------------------------------------------------------------------++goldenTokenV4Local :: Token V4 Local+goldenTokenV4Local =+  TokenV4Local+    (Payload "\223eH\DC2\186\196\146f8%R\v\162\246\230|\245\202[\220\DC3\212\231Pz\152\204L/\204:\216\192\226H\170\195\191\237q\163\140\228cDrt\241\151\173\SYN\136\SI+w| \NAK#[\253GI=x\233\206m\n[\218#3\151\248;i\145\188M\136s\a\143\248\244]\160x\221\231\228G\n!1GR\n\234\222\169Y 9\GS}\176\141\189\207\251\DC2\208\131\146\185}\229\STX_\131\246~\149J\221\146\214\NAK\179\DC2\197")+    (Just (Footer "{\"kid\":\"zVhMiPBP9fRf2snEcT7gFTioeA9COcNy9DfgL1W60haN\"}"))++goldenTokenV4Public :: Token V4 Public+goldenTokenV4Public =+  TokenV4Public+    (Payload "{\"data\":\"this is a signed message\",\"exp\":\"2022-01-01T00:00:00+00:00\"}\191rm\242l\DELM\211\&6q\228\198\162\172+\135\140\131\SYN}\ETB\176{\239W\240\244\SO\220\DLE\197Z\201\DLE\DC3%\208]\156h\a`\158\146\165\183\138{\196\EM\241\212w\SO\249#\232\240S\233\219^\a\SI")+    (Just (Footer "{\"kid\":\"zVhMiPBP9fRf2snEcT7gFTioeA9COcNy9DfgL1W60haN\"}"))++------------------------------------------------------------------------------+-- Helpers+------------------------------------------------------------------------------++unsafeRenderSymmetricKey :: SymmetricKey v -> String+unsafeRenderSymmetricKey k =+  case k of+    SymmetricKeyV3 bs -> "SymmetricKeyV3 " <> show bs+    SymmetricKeyV4 bs -> "SymmetricKeyV4 " <> show bs++unsafeRenderSigningKey :: SigningKey v -> String+unsafeRenderSigningKey sk =+  case sk of+    SigningKeyV3 k -> "SigningKeyV3 " <> show k+    SigningKeyV4 bs -> "SigningKeyV4 " <> show bs
+ test/Test/Crypto/Paseto/ScrubbedBytes/Gen.hs view
@@ -0,0 +1,16 @@+module Test.Crypto.Paseto.ScrubbedBytes.Gen+  ( genScrubbedBytes32+  ) where++import Crypto.Paseto.ScrubbedBytes ( ScrubbedBytes32, mkScrubbedBytes32 )+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude++genScrubbedBytes32 :: Gen (ScrubbedBytes32)+genScrubbedBytes32 = do+  bs <- Gen.bytes (Range.singleton 32)+  case mkScrubbedBytes32 bs of+    Nothing -> fail "failed to generate a ScrubbedBytes32"+    Just x -> pure x
+ test/Test/Crypto/Paseto/TestVectorTest.hs view
@@ -0,0 +1,39 @@+module Test.Crypto.Paseto.TestVectorTest+  ( tests+  ) where++import Control.Monad.IO.Class ( MonadIO (..) )+import qualified Data.Aeson as Aeson+import Data.String ( fromString )+import Hedgehog ( Group (..), checkParallel, property, withTests )+import Prelude+import Test.Crypto.Paseto.TestVectors+  ( mkV3TestVectorProperties, mkV4TestVectorProperties )++tests :: IO Bool+tests =+  and <$> mapM (>>= checkParallel) [testVectorsV3, testVectorsV4]++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++testVectorsV3 :: MonadIO m => m Group+testVectorsV3 = do+  res <- liftIO (Aeson.eitherDecodeFileStrict "test/test-vectors/v3.json")+  case res of+    Left err -> error $ "failed to decode V3 test vectors: " <> show err+    Right tvs ->+      pure $ Group "Test Vectors V3" $+        flip map (mkV3TestVectorProperties tvs) $ \(propName, prop) ->+          (fromString propName, withTests 1 (property prop))++testVectorsV4 :: MonadIO m => m Group+testVectorsV4 = do+  res <- liftIO (Aeson.eitherDecodeFileStrict "test/test-vectors/v4.json")+  case res of+    Left err -> error $ "failed to decode V4 test vectors: " <> show err+    Right tvs ->+      pure $ Group "Test Vectors V4" $+        flip map (mkV4TestVectorProperties tvs) $ \(propName, prop) ->+          (fromString propName, withTests 1 (property prop))
+ test/Test/Crypto/Paseto/TestVectors.hs view
@@ -0,0 +1,300 @@+module Test.Crypto.Paseto.TestVectors+  ( Base16ByteString (..)+  , LocalTestVector (..)+  , PublicTestVector (..)+  , TestVector (..)+  , TestVectors (..)+  , mkV3TestVectorProperties+  , mkV4TestVectorProperties+  ) where++import Control.Monad.Except ( ExceptT, runExceptT )+import Control.Monad.Trans.Except.Extra ( left )+import Crypto.Paseto.Keys+  ( bytesToSymmetricKeyV3+  , bytesToSymmetricKeyV4+  , bytesToVerificationKeyV3+  , bytesToVerificationKeyV4+  )+import Crypto.Paseto.Token ( Footer (..), ImplicitAssertion (..) )+import Crypto.Paseto.Token.Encoding+  ( ValidatedToken (..)+  , decodeTokenV3Local+  , decodeTokenV3Public+  , decodeTokenV4Local+  , decodeTokenV4Public+  )+import Data.Aeson ( FromJSON (..), withObject, withText, (.:), (.:?) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import Data.ByteArray ( ByteArrayAccess )+import qualified Data.ByteArray as BA+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Base16 as B16+import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Hedgehog ( PropertyT, (===) )+import Prelude++emptyToNothing :: (ByteString -> a) -> ByteString -> Maybe a+emptyToNothing _ "" = Nothing+emptyToNothing f bs = Just (f bs)++data ExpectedFailure = ExpectedFailure++handlePropertyWithExpectedFailure+  :: PropertyT IO (Either ExpectedFailure ())+  -> PropertyT IO ()+handlePropertyWithExpectedFailure prop = do+  res <- prop+  case res of+    Left ExpectedFailure -> pure ()+    Right () -> pure ()++-- | 'ByteString' that was decoded from base16-encoded text.+newtype Base16ByteString = Base16ByteString+  { unBase16ByteString :: ByteString }+  deriving newtype (Show, Eq, ByteArrayAccess)++instance FromJSON Base16ByteString where+  parseJSON = withText "Base16ByteString" $ \t ->+    case B16.decode (TE.encodeUtf8 t) of+      Left err -> fail $ "error decoding text as base16: " <> err+      Right x -> pure (Base16ByteString x)++-- | Test vector for a local PASETO token.+data LocalTestVector = LocalTestVector+  { ltvName :: !Text+  , ltvExpectFail :: !Bool+  , ltvKey :: !Base16ByteString+  , ltvNonce :: !Base16ByteString+  , ltvToken :: !Text+  , ltvPayload :: !(Maybe Text)+  , ltvFooter :: !(Maybe Footer)+  , ltvImplicitAssertion :: !(Maybe ImplicitAssertion)+  } deriving stock (Show, Eq)++instance FromJSON LocalTestVector where+  parseJSON = withObject "LocalTestVector" $ \v ->+    LocalTestVector+      <$> v .: "name"+      <*> v .: "expect-fail"+      <*> v .: "key"+      <*> v .: "nonce"+      <*> v .: "token"+      <*> v .: "payload"+      <*> (emptyToNothing Footer . TE.encodeUtf8 <$> v .: "footer")+      <*> (emptyToNothing ImplicitAssertion . TE.encodeUtf8 <$> v .: "implicit-assertion")++mkV3LocalTestVectorProperty :: LocalTestVector -> (String, PropertyT IO ())+mkV3LocalTestVectorProperty ltv =+  (T.unpack ltvName, handlePropertyWithExpectedFailure (runExceptT mkProp))+  where+    LocalTestVector+      { ltvName+      , ltvKey+      , ltvToken+      , ltvPayload+      , ltvFooter+      , ltvImplicitAssertion+      } = ltv++    mkProp :: ExceptT ExpectedFailure (PropertyT IO) ()+    mkProp = do+      key <-+        case bytesToSymmetricKeyV3 (BA.convert ltvKey) of+          Nothing -> fail "invalid version 3 symmetric key"+          Just k -> pure k++      case decodeTokenV3Local key [] ltvFooter ltvImplicitAssertion ltvToken of+        Left err ->+          case ltvPayload of+            Nothing -> left ExpectedFailure+            Just _ -> fail $ "invalid version 3 local token (" <> T.unpack ltvToken <> "): " <> show err+        Right ValidatedToken{ vtClaims } ->+          case ltvPayload of+            Nothing -> fail "expected token decoding failure"+            Just expectedPayload -> do+              expectedClaims <-+                case Aeson.eitherDecodeStrict (TE.encodeUtf8 expectedPayload) of+                  Left err -> fail $ "invalid claims payload: " <> show err+                  Right x -> pure x+              expectedClaims === vtClaims++mkV4LocalTestVectorProperty :: LocalTestVector -> (String, PropertyT IO ())+mkV4LocalTestVectorProperty ltv =+  (T.unpack ltvName, handlePropertyWithExpectedFailure (runExceptT mkProp))+  where+    LocalTestVector+      { ltvName+      , ltvKey+      , ltvToken+      , ltvPayload+      , ltvFooter+      , ltvImplicitAssertion+      } = ltv++    mkProp :: ExceptT ExpectedFailure (PropertyT IO) ()+    mkProp = do+      key <-+        case bytesToSymmetricKeyV4 (BA.convert ltvKey) of+          Nothing -> fail "invalid version 4 symmetric key"+          Just k -> pure k++      case decodeTokenV4Local key [] ltvFooter ltvImplicitAssertion ltvToken of+        Left err ->+          case ltvPayload of+            Nothing -> left ExpectedFailure+            Just _ -> fail $ "invalid version 4 local token (" <> T.unpack ltvToken <> "): " <> show err+        Right ValidatedToken{ vtClaims } ->+          case ltvPayload of+            Nothing -> fail "expected token decoding failure"+            Just expectedPayload -> do+              expectedClaims <-+                case Aeson.eitherDecodeStrict (TE.encodeUtf8 expectedPayload) of+                  Left err -> fail $ "invalid claims payload: " <> show err+                  Right x -> pure x+              expectedClaims === vtClaims++-- | Test vector for a public PASETO token.+data PublicTestVector = PublicTestVector+  { ptvName :: !Text+  , ptvExpectFail :: !Bool+  , ptvPublicKey :: !Base16ByteString+  , ptvSecretKey :: !Base16ByteString+  , ptvPublicKeyPem :: !Text+  , ptvSecretKeyPem :: !Text+  , ptvToken :: !Text+  , ptvPayload :: !(Maybe Text)+  , ptvFooter :: !(Maybe Footer)+  , ptvImplicitAssertion :: !(Maybe ImplicitAssertion)+  } deriving stock (Show, Eq)++instance FromJSON PublicTestVector where+  parseJSON = withObject "PublicTestVector" $ \v ->+    PublicTestVector+      <$> v .: "name"+      <*> v .: "expect-fail"+      <*> v .: "public-key"+      <*> v .: "secret-key"+      <*> v .: "public-key-pem"+      <*> v .: "secret-key-pem"+      <*> v .: "token"+      <*> v .: "payload"+      <*> (emptyToNothing Footer . TE.encodeUtf8 <$> v .: "footer")+      <*> (emptyToNothing ImplicitAssertion . TE.encodeUtf8 <$> v .: "implicit-assertion")++mkV3PublicTestVectorProperty :: PublicTestVector -> (String, PropertyT IO ())+mkV3PublicTestVectorProperty ptv =+  (T.unpack ptvName, handlePropertyWithExpectedFailure (runExceptT mkProp))+  where+    PublicTestVector+      { ptvName+      , ptvPublicKey+      , ptvToken+      , ptvPayload+      , ptvFooter+      , ptvImplicitAssertion+      } = ptv++    mkProp :: ExceptT ExpectedFailure (PropertyT IO) ()+    mkProp = do+      vk <-+        case bytesToVerificationKeyV3 (unBase16ByteString ptvPublicKey) of+          Left err -> fail $ "invalid version 3 verification key: " <> show err+          Right k -> pure k++      case decodeTokenV3Public vk [] ptvFooter ptvImplicitAssertion ptvToken of+        Left err ->+          case ptvPayload of+            Nothing -> left ExpectedFailure+            Just _ -> fail $ "invalid version 3 public token (" <> T.unpack ptvToken <> "): " <> show err+        Right ValidatedToken{ vtClaims } ->+          case ptvPayload of+            Nothing -> fail "expected token decoding failure"+            Just expectedPayload -> do+              expectedClaims <-+                case Aeson.eitherDecodeStrict (TE.encodeUtf8 expectedPayload) of+                  Left err -> fail $ "invalid claims payload: " <> show err+                  Right x -> pure x+              expectedClaims === vtClaims++mkV4PublicTestVectorProperty :: PublicTestVector -> (String, PropertyT IO ())+mkV4PublicTestVectorProperty ptv =+  (T.unpack ptvName, handlePropertyWithExpectedFailure (runExceptT mkProp))+  where+    PublicTestVector+      { ptvName+      , ptvPublicKey+      , ptvToken+      , ptvPayload+      , ptvFooter+      , ptvImplicitAssertion+      } = ptv++    mkProp :: ExceptT ExpectedFailure (PropertyT IO) ()+    mkProp = do+      vk <-+        case bytesToVerificationKeyV4 (unBase16ByteString ptvPublicKey) of+          Nothing -> fail "invalid version 4 verification key"+          Just k -> pure k++      case decodeTokenV4Public vk [] ptvFooter ptvImplicitAssertion ptvToken of+        Left err ->+          case ptvPayload of+            Nothing -> left ExpectedFailure+            Just _ -> fail $ "invalid version 4 public token (" <> T.unpack ptvToken <> "): " <> show err+        Right ValidatedToken{ vtClaims } ->+          case ptvPayload of+            Nothing -> fail "expected token decoding failure"+            Just expectedPayload -> do+              expectedClaims <-+                case Aeson.eitherDecodeStrict (TE.encodeUtf8 expectedPayload) of+                  Left err -> fail $ "invalid claims payload: " <> show err+                  Right x -> pure x+              expectedClaims === vtClaims++-- | Test vector.+data TestVector+  = -- | Test vector for a local PASETO token.+    TestVectorLocal !LocalTestVector+  | -- | Test vector for a public PASETO token.+    TestVectorPublic !PublicTestVector+  deriving stock (Show, Eq)++instance FromJSON TestVector where+  parseJSON v = withObject "TestVector" f v+    where+      f o = do+        symmetricKey <- o .:? "key" :: Aeson.Parser (Maybe Base16ByteString)+        case symmetricKey of+          Just _ -> TestVectorLocal <$> parseJSON v+          Nothing -> TestVectorPublic <$> parseJSON v++mkV3TestVectorProperty :: TestVector -> (String, PropertyT IO ())+mkV3TestVectorProperty tv =+  case tv of+    TestVectorLocal ltv -> mkV3LocalTestVectorProperty ltv+    TestVectorPublic ptv -> mkV3PublicTestVectorProperty ptv++mkV4TestVectorProperty :: TestVector -> (String, PropertyT IO ())+mkV4TestVectorProperty tv =+  case tv of+    TestVectorLocal ltv -> mkV4LocalTestVectorProperty ltv+    TestVectorPublic ptv -> mkV4PublicTestVectorProperty ptv++-- | List of 'TestVector's.+newtype TestVectors = TestVectors+  { unTestVectors :: [TestVector] }+  deriving newtype (Show, Eq)++instance FromJSON TestVectors where+  parseJSON = withObject "TestVectors" $ \v -> do+    TestVectors <$> v .: "tests"++mkV3TestVectorProperties :: TestVectors -> [(String, PropertyT IO ())]+mkV3TestVectorProperties = map mkV3TestVectorProperty . unTestVectors++mkV4TestVectorProperties :: TestVectors -> [(String, PropertyT IO ())]+mkV4TestVectorProperties = map mkV4TestVectorProperty . unTestVectors
+ test/Test/Crypto/Paseto/Token/Claim.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Token.Claim+  ( tests+  ) where++import Control.Monad ( void )+import Crypto.Paseto.Token.Claim+  ( ClaimKey (..)+  , mkUnregisteredClaimKey+  , parseClaimKey+  , renderClaimKey+  , renderUnregisteredClaimKey+  )+import Hedgehog+  ( Property+  , checkParallel+  , discover+  , evalMaybe+  , forAll+  , property+  , tripping+  , (===)+  )+import Prelude+import Test.Crypto.Paseto.Token.Claim.Gen+  ( genClaimKey, genUnregisteredClaimKey )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'renderClaimKey' and 'parseClaimKey' round trip.+prop_roundTrip_renderParseClaimKey :: Property+prop_roundTrip_renderParseClaimKey = property $ do+  k <- forAll genClaimKey+  tripping k renderClaimKey (Just . parseClaimKey)++-- | Test that 'renderUnregisteredClaimKey' and 'mkUnregisteredClaimKey' round+-- trip.+prop_roundTrip_renderMkUnregisteredClaimKey :: Property+prop_roundTrip_renderMkUnregisteredClaimKey = property $ do+  k <- forAll genUnregisteredClaimKey+  tripping k renderUnregisteredClaimKey mkUnregisteredClaimKey++-- | Test that it isn't possible to construct an 'UnregisteredClaimKey' that+-- is a registered/reserved claim key.+prop_unregisteredClaimKeyCannotBeRegistered :: Property+prop_unregisteredClaimKeyCannotBeRegistered = property $ do+  k <- forAll genClaimKey+  case k of+    CustomClaimKey _ ->+      -- @k@ is a custom/unregistered claim key, so we should be able to render+      -- it and successfully re-construct an 'UnregisteredClaimKey'.+      void $ evalMaybe (mkUnregisteredClaimKey $ renderClaimKey k)+    _ ->+      -- @k@ is a registered claim key, so we shouldn't be able to render it+      -- and construct an 'UnregisteredClaimKey'.+      Nothing === mkUnregisteredClaimKey (renderClaimKey k)
+ test/Test/Crypto/Paseto/Token/Claim/Gen.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Test.Crypto.Paseto.Token.Claim.Gen+  ( genUnregisteredClaimKey+  , genCustomClaimKey+  , genClaimKey+  , genIssuer+  , genSubject+  , genAudience+  , genExpiration+  , genNotBefore+  , genIssuedAt+  , genTokenIdentifier+  , genClaim+  , genAesonString+  , genUTCTime+  ) where++import Crypto.Paseto.Token.Claim+  ( Audience (..)+  , Claim (..)+  , ClaimKey (..)+  , Expiration (..)+  , IssuedAt (..)+  , Issuer (..)+  , NotBefore (..)+  , Subject (..)+  , TokenIdentifier (..)+  , UnregisteredClaimKey+  , mkUnregisteredClaimKey+  , parseClaimKey+  , registeredClaimKeys+  )+import qualified Data.Set as Set+import Data.Text ( Text )+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Gen ( genAesonString, genUTCTime )++genUnregisteredClaimKey :: Gen UnregisteredClaimKey+genUnregisteredClaimKey =+  Gen.mapMaybe+    (mkUnregisteredClaimKey)+    (Gen.text (Range.constant 0 1024) Gen.unicodeAll)++genCustomClaimKey :: Gen ClaimKey+genCustomClaimKey = Gen.filter isNotRegistered (parseClaimKey <$> genText)+  where+    isNotRegistered :: ClaimKey -> Bool+    isNotRegistered k = Set.notMember k registeredClaimKeys++    genText :: Gen Text+    genText = Gen.text (Range.constant 0 1024) Gen.unicodeAll++genClaimKey :: Gen ClaimKey+genClaimKey =+  Gen.choice (genCustomClaimKey : map pure (Set.toList registeredClaimKeys))++genIssuer :: Gen Issuer+genIssuer = Issuer <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++genSubject :: Gen Subject+genSubject = Subject <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++genAudience :: Gen Audience+genAudience = Audience <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++genExpiration :: Gen Expiration+genExpiration = Expiration <$> genUTCTime++genNotBefore :: Gen NotBefore+genNotBefore = NotBefore <$> genUTCTime++genIssuedAt :: Gen IssuedAt+genIssuedAt = IssuedAt <$> genUTCTime++genTokenIdentifier :: Gen TokenIdentifier+genTokenIdentifier = TokenIdentifier <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++genClaim :: Gen Claim+genClaim =+  Gen.choice+    [ IssuerClaim <$> genIssuer+    , SubjectClaim <$> genSubject+    , AudienceClaim <$> genAudience+    , ExpirationClaim <$> genExpiration+    , NotBeforeClaim <$> genNotBefore+    , IssuedAtClaim <$> genIssuedAt+    , TokenIdentifierClaim <$> genTokenIdentifier+    , CustomClaim <$> genUnregisteredClaimKey <*> genAesonString+    ]
+ test/Test/Crypto/Paseto/Token/Claims.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Token.Claims+  ( tests+  ) where++import Crypto.Paseto.Token.Claim ( Claim (..), claimKey )+import qualified Crypto.Paseto.Token.Claims as Claims+import Data.Foldable ( foldl' )+import qualified Data.List as L+import qualified Data.Set as Set+import Hedgehog+  ( Property+  , assert+  , checkParallel+  , discover+  , forAll+  , property+  , tripping+  , withTests+  , (===)+  )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude hiding ( exp )+import Test.Crypto.Paseto.Token.Claim.Gen+  ( genAesonString+  , genAudience+  , genClaim+  , genExpiration+  , genIssuedAt+  , genIssuer+  , genNotBefore+  , genSubject+  , genTokenIdentifier+  , genUnregisteredClaimKey+  )+import Test.Crypto.Paseto.Token.Claims.Gen ( genClaims, genNonEmptyClaims )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'Claims.toList' and 'Claims.fromList' round trip.+prop_roundTrip_toFromList :: Property+prop_roundTrip_toFromList = property $ do+  cs <- forAll genClaims+  tripping cs Claims.toList (Just . Claims.fromList)++-- | Test that the size of an empty collection of claims is zero.+prop_emptySizeIsZero :: Property+prop_emptySizeIsZero = withTests 1 . property $ do+  Claims.size (Claims.empty) === 0+  Claims.size (Claims.fromList []) === 0++-- | Test that the size of a 'Claims' value constructed with 'Claims.singleton'+-- is one.+prop_singletonSizeIsOne :: Property+prop_singletonSizeIsOne = property $ do+  c <- forAll genClaim+  Claims.size (Claims.singleton c) === 1++-- | Test that 'Claims.size' accurately reflects the size of the collection.+prop_size :: Property+prop_size = property $ do+  claimsList <- forAll $ Gen.list (Range.constant 0 32) genClaim+  let expectedSize = countUniqueClaims claimsList+      actualSize = Claims.size (Claims.fromList claimsList)+  expectedSize === actualSize+  where+    countUniqueClaims :: [Claim] -> Int+    countUniqueClaims = Set.size . foldl' (\acc c -> Set.insert (claimKey c) acc) Set.empty++-- | Test that 'Claims.null' appropriately reflects whether the collection is+-- empty.+prop_null :: Property+prop_null = property $ do+  claims <- forAll genClaims+  case Claims.size claims of+    0 -> assert (Claims.null claims)+    _ -> assert (not $ Claims.null claims)++-- | Test that 'Claims.delete' deletes a claim from the collection.+prop_delete :: Property+prop_delete = property $ do+  claims <- forAll genNonEmptyClaims+  let claimsList = Claims.toList claims+  randomClaim <- forAll $ Gen.element claimsList+  Claims.toList (Claims.delete (claimKey randomClaim) claims) === L.delete randomClaim claimsList++-- | Test that 'Claims.insert' inserts a claim into the collection.+prop_insert :: Property+prop_insert = property $ do+  claims <- forAll genClaims+  claim <- forAll genClaim+  assert (L.elem claim $ Claims.toList (Claims.insert claim claims))++prop_lookupIssuer :: Property+prop_lookupIssuer = property $ do+  iss <- forAll genIssuer+  claims <- forAll $ Claims.insert (IssuerClaim iss) <$> genClaims+  Just iss === Claims.lookupIssuer claims++prop_lookupSubject :: Property+prop_lookupSubject = property $ do+  sub <- forAll genSubject+  claims <- forAll $ Claims.insert (SubjectClaim sub) <$> genClaims+  Just sub === Claims.lookupSubject claims++prop_lookupAudience :: Property+prop_lookupAudience = property $ do+  aud <- forAll genAudience+  claims <- forAll $ Claims.insert (AudienceClaim aud) <$> genClaims+  Just aud === Claims.lookupAudience claims++prop_lookupExpiration :: Property+prop_lookupExpiration = property $ do+  exp <- forAll genExpiration+  claims <- forAll $ Claims.insert (ExpirationClaim exp) <$> genClaims+  Just exp === Claims.lookupExpiration claims++prop_lookupNotBefore :: Property+prop_lookupNotBefore = property $ do+  nbf <- forAll genNotBefore+  claims <- forAll $ Claims.insert (NotBeforeClaim nbf) <$> genClaims+  Just nbf === Claims.lookupNotBefore claims++prop_lookupIssuedAt :: Property+prop_lookupIssuedAt = property $ do+  iat <- forAll genIssuedAt+  claims <- forAll $ Claims.insert (IssuedAtClaim iat) <$> genClaims+  Just iat === Claims.lookupIssuedAt claims++prop_lookupTokenIdentifier :: Property+prop_lookupTokenIdentifier = property $ do+  jti <- forAll genTokenIdentifier+  claims <- forAll $ Claims.insert (TokenIdentifierClaim jti) <$> genClaims+  Just jti === Claims.lookupTokenIdentifier claims++prop_lookupCustom :: Property+prop_lookupCustom = property $ do+  k <- forAll genUnregisteredClaimKey+  v <- forAll genAesonString+  claims <- forAll $ Claims.insert (CustomClaim k v) <$> genClaims+  Just v === Claims.lookupCustom k claims
+ test/Test/Crypto/Paseto/Token/Claims/Gen.hs view
@@ -0,0 +1,17 @@+module Test.Crypto.Paseto.Token.Claims.Gen+  ( genClaims+  , genNonEmptyClaims+  ) where++import Crypto.Paseto.Token.Claims ( Claims, fromList )+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude+import Test.Crypto.Paseto.Token.Claim.Gen ( genClaim )++genClaims :: Gen Claims+genClaims = fromList <$> Gen.list (Range.constant 0 32) genClaim++genNonEmptyClaims :: Gen Claims+genNonEmptyClaims = fromList <$> Gen.list (Range.constant 1 32) genClaim
+ test/Test/Crypto/Paseto/Token/Gen.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Test.Crypto.Paseto.Token.Gen+  ( genPayload+  , genFooter+  , genImplicitAssertion+  , genTokenV3Local+  , genTokenV3Public+  , genTokenV4Local+  , genTokenV4Public+  , genSomeToken+  ) where++import Crypto.Paseto.Mode ( Purpose (..), Version (..) )+import Crypto.Paseto.Token+  ( Footer (..)+  , ImplicitAssertion (..)+  , Payload (..)+  , SomeToken (..)+  , Token (..)+  )+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude++genPayload :: Gen Payload+genPayload = Payload <$> Gen.bytes (Range.constant 1 1024)++genFooter :: Gen Footer+genFooter = Footer <$> Gen.bytes (Range.constant 1 1024)++genImplicitAssertion :: Gen ImplicitAssertion+genImplicitAssertion = ImplicitAssertion <$> Gen.bytes (Range.constant 1 1024)++-- | Generate a cryptographically-invalid PASETO v3 local token.+genTokenV3Local :: Gen (Token V3 Local)+genTokenV3Local =+  TokenV3Local+    <$> genPayload+    <*> Gen.maybe genFooter++-- | Generate a cryptographically-invalid PASETO v3 public token.+genTokenV3Public :: Gen (Token V3 Public)+genTokenV3Public =+  TokenV3Public+    <$> genPayload+    <*> Gen.maybe genFooter++-- | Generate a cryptographically-invalid PASETO v4 local token.+genTokenV4Local :: Gen (Token V4 Local)+genTokenV4Local =+  TokenV4Local+    <$> genPayload+    <*> Gen.maybe genFooter++-- | Generate a cryptographically-invalid PASETO v4 public token.+genTokenV4Public :: Gen (Token V4 Public)+genTokenV4Public =+  TokenV4Public+    <$> genPayload+    <*> Gen.maybe genFooter++-- | Generate a cryptographically-invalid PASETO token.+genSomeToken :: Gen SomeToken+genSomeToken =+  Gen.choice+    [ SomeTokenV3Local <$> genTokenV3Local+    , SomeTokenV3Public <$> genTokenV3Public+    , SomeTokenV4Local <$> genTokenV4Local+    , SomeTokenV4Public <$> genTokenV4Public+    ]
+ test/Test/Crypto/Paseto/Token/Parser.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Token.Parser+  ( tests+  ) where++import Crypto.Paseto.Token.Encoding ( encode, encodeSomeToken )+import Crypto.Paseto.Token.Parser+  ( parseSomeToken+  , parseTokenV3Local+  , parseTokenV3Public+  , parseTokenV4Local+  , parseTokenV4Public+  )+import Hedgehog+  ( Property, checkParallel, discover, forAll, property, tripping )+import Prelude+import Test.Crypto.Paseto.Token.Gen+  ( genSomeToken+  , genTokenV3Local+  , genTokenV3Public+  , genTokenV4Local+  , genTokenV4Public+  )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'encode' and 'parseTokenV3Local' round trip.+prop_roundTrip_encodeParseTokenV3Local :: Property+prop_roundTrip_encodeParseTokenV3Local = property $ do+  token <- forAll genTokenV3Local+  tripping token encode parseTokenV3Local++-- | Test that 'encode' and 'parseTokenV3Public' round trip.+prop_roundTrip_encodeParseTokenV3Public :: Property+prop_roundTrip_encodeParseTokenV3Public = property $ do+  token <- forAll genTokenV3Public+  tripping token encode parseTokenV3Public++-- | Test that 'encode' and 'parseTokenV4Local' round trip.+prop_roundTrip_encodeParseTokenV4Local :: Property+prop_roundTrip_encodeParseTokenV4Local = property $ do+  token <- forAll genTokenV4Local+  tripping token encode parseTokenV4Local++-- | Test that 'encode' and 'parseTokenV4Public' round trip.+prop_roundTrip_encodeParseTokenV4Public :: Property+prop_roundTrip_encodeParseTokenV4Public = property $ do+  token <- forAll genTokenV4Public+  tripping token encode parseTokenV4Public++-- | Test that 'encodeSomeToken' and 'parseSomeToken' round trip.+prop_roundTrip_encodeParseSomeToken :: Property+prop_roundTrip_encodeParseSomeToken = property $ do+  token <- forAll genSomeToken+  tripping token encodeSomeToken parseSomeToken
+ test/Test/Crypto/Paseto/Token/Validation.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Crypto.Paseto.Token.Validation+  ( tests+  ) where++import Crypto.Paseto.Token.Claim+  ( Claim (..), Expiration (..), IssuedAt (..), NotBefore (..) )+import qualified Crypto.Paseto.Token.Claims as Claims+import Crypto.Paseto.Token.Validation+  ( ValidationError (..)+  , forAudience+  , identifiedBy+  , issuedBy+  , notExpired+  , subject+  , validAt+  , validate+  )+import Data.Either ( isLeft )+import Data.Fixed ( Fixed (..), Pico, resolution )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Time.Clock ( NominalDiffTime, addUTCTime, nominalDiffTimeToSeconds )+import Hedgehog+  ( MonadTest+  , Property+  , annotateShow+  , assert+  , checkParallel+  , discover+  , evalEither+  , forAll+  , forAllWith+  , property+  , withTests+  , (===)+  )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude hiding ( exp )+import Test.Crypto.Paseto.Token.Claim.Gen+  ( genAudience, genIssuer, genSubject, genTokenIdentifier )+import Test.Crypto.Paseto.Token.Validation.Gen ( genConstValidationRule )+import Test.Gen ( genNominalDiffTime, genUTCTime )++tests :: IO Bool+tests = checkParallel $$(discover)++------------------------------------------------------------------------------+-- Properties+------------------------------------------------------------------------------++-- | Test that 'validate' succeeds when all rules pass and fails when any rule+-- fails.+prop_validate :: Property+prop_validate = property $ do+  rules <- forAllWith renderRules $ Gen.list (Range.constant 1 128) genConstValidationRule+  let expectSuccess = and (map snd rules)+      validationResult = validate (map fst rules) Claims.empty+  if expectSuccess+    then evalEither validationResult+    else assert (isLeft validationResult)+  where+    renderRules xs = show $ map snd xs++prop_forAudience :: Property+prop_forAudience = property $ do+  aud <- forAll genAudience+  let claims = Claims.singleton (AudienceClaim aud)++  -- Expected success case+  evalEither (validate [forAudience aud] claims)++  -- Expected failure case+  wrong <- forAll $ Gen.filter (/= aud) genAudience+  assert $ isLeft (validate [forAudience wrong] claims)++prop_identifiedBy :: Property+prop_identifiedBy = property $ do+  jti <- forAll genTokenIdentifier+  let claims = Claims.singleton (TokenIdentifierClaim jti)++  -- Expected success case+  evalEither (validate [identifiedBy jti] claims)++  -- Expected failure case+  wrong <- forAll $ Gen.filter (/= jti) genTokenIdentifier+  assert $ isLeft (validate [identifiedBy wrong] claims)++prop_issuedBy :: Property+prop_issuedBy = property $ do+  iss <- forAll genIssuer+  let claims = Claims.singleton (IssuerClaim iss)++  -- Expected success case+  evalEither (validate [issuedBy iss] claims)++  -- Expected failure case+  wrong <- forAll $ Gen.filter (/= iss) genIssuer+  assert $ isLeft (validate [issuedBy wrong] claims)++prop_subject :: Property+prop_subject = property $ do+  sub <- forAll genSubject+  let claims = Claims.singleton (SubjectClaim sub)++  -- Expected success case+  evalEither (validate [subject sub] claims)++  -- Expected failure case+  wrong <- forAll $ Gen.filter (/= sub) genSubject+  assert $ isLeft (validate [subject wrong] claims)++prop_notExpired :: Property+prop_notExpired = withTests 5000 . property $ do+  time <- forAll genUTCTime+  expTimeDiff <- forAll $ genNominalDiffTime (Range.constant 0 100000)+  let expClaimTime = addUTCTime expTimeDiff time+      exp = Expiration expClaimTime+      claims = Claims.singleton (ExpirationClaim exp)++  -- Expected success case+  goodTime <- forAll $ do+    diff <- genNominalDiffTime (Range.constant 0 (nominalDiffTimeToSecondsI expTimeDiff))+    pure (addUTCTime diff time)+  evalEither (validate [notExpired goodTime] claims)++  -- Expected failure case+  badTime <- forAll $ do+    diff <- genNominalDiffTime (Range.constant 1 100000)+    pure (addUTCTime diff expClaimTime)+  assertErrors+    (NE.singleton $ ValidationExpirationError exp)+    (validate [notExpired badTime] claims)++prop_validAt :: Property+prop_validAt = withTests 5000 . property $ do+  timeBeforeIssue <- forAll genUTCTime++  iatTimeDiff <- forAll $ genNominalDiffTime (Range.constant 1 100000)+  let iatTime = addUTCTime iatTimeDiff timeBeforeIssue++  nbfTimeDiff <- forAll $ genNominalDiffTime (Range.constant 0 100000)+  let nbfTime = addUTCTime nbfTimeDiff iatTime++  expTimeDiff <- forAll $ genNominalDiffTime (Range.constant 1 100000)+  let expTime = addUTCTime expTimeDiff nbfTime++  let iat = IssuedAt iatTime+      nbf = NotBefore nbfTime+      exp = Expiration expTime+      claims =+        Claims.fromList+          [ IssuedAtClaim iat+          , NotBeforeClaim nbf+          , ExpirationClaim exp+          ]++  annotateShow claims++  -- Expected success case+  goodTime <- forAll $ do+    diff <- genNominalDiffTime (Range.constant 0 (nominalDiffTimeToSecondsI expTimeDiff))+    pure (addUTCTime diff nbfTime)+  evalEither (validate [validAt goodTime] claims)++  -- Expected failure case (claims not yet issued)+  badTimeBeforeIat <- forAll $ do+    diff <- genNominalDiffTime (Range.constant 0 ((nominalDiffTimeToSecondsI iatTimeDiff) - 1))+    pure (addUTCTime diff timeBeforeIssue)+  assertErrors+    (NE.singleton $ ValidationIssuedAtError iat)+    (validate [validAt badTimeBeforeIat] claims)++  -- Expected failure case (time is before `nbf`)+  badTimeBeforeNbf <- forAll $+    case nbfTimeDiff of+      0 -> do+        diff <- genNominalDiffTime (Range.constant 0 ((nominalDiffTimeToSecondsI iatTimeDiff) - 1))+        pure (addUTCTime diff timeBeforeIssue)+      _ -> do+        diff <- genNominalDiffTime (Range.constant 0 ((nominalDiffTimeToSecondsI nbfTimeDiff) - 1))+        pure (addUTCTime diff iatTime)+  assertErrors+    (NE.singleton $ ValidationNotBeforeError nbf)+    (validate [validAt badTimeBeforeNbf] claims)++  -- Expected failure case (expired claims)+  badTimeAfterExp <- forAll $ do+    diff <- genNominalDiffTime (Range.constant 1 100000)+    pure (addUTCTime diff expTime)+  assertErrors+    (NE.singleton $ ValidationExpirationError exp)+    (validate [validAt badTimeAfterExp] claims)++------------------------------------------------------------------------------+-- Helpers+------------------------------------------------------------------------------++nominalDiffTimeToSecondsI :: NominalDiffTime -> Integer+nominalDiffTimeToSecondsI t = unFixed s `div` resolution s+  where+    s :: Pico+    s = nominalDiffTimeToSeconds t++    unFixed :: Fixed a -> Integer+    unFixed (MkFixed a) = a++assertErrors+  :: MonadTest m+  => NonEmpty ValidationError+  -> Either (NonEmpty ValidationError) ()+  -> m ()+assertErrors expectedErrs actualRes =+  Left expectedErrs === actualRes
+ test/Test/Crypto/Paseto/Token/Validation/Gen.hs view
@@ -0,0 +1,25 @@+module Test.Crypto.Paseto.Token.Validation.Gen+  ( genConstValidationRule+  ) where++import Crypto.Paseto.Token.Validation+  ( ValidationError (..), ValidationRule (..) )+import Hedgehog ( Gen )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude++genValidationCustomError :: Gen ValidationError+genValidationCustomError = ValidationCustomError <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++-- | Generate a simple 'ValidationRule' that either returns a 'Left'+-- 'ValidationCustomError' or '()' regardless of the claims value its given.+--+-- In addition to the generated rule, a 'Bool' value which indicates whether+-- success should be expected is also provided.+genConstValidationRule :: Gen (ValidationRule, Bool)+genConstValidationRule = do+  res <- Gen.either genValidationCustomError (pure ())+  case res of+    Left _ -> pure (ValidationRule (const res), False)+    Right _ -> pure (ValidationRule (const res), True)
+ test/Test/Gen.hs view
@@ -0,0 +1,35 @@+module Test.Gen+  ( genAesonString+  , genUTCTime+  , genNominalDiffTime+  ) where++import qualified Data.Aeson as Aeson+import Data.Time.Calendar.OrdinalDate ( Day, fromOrdinalDate )+import Data.Time.Clock+  ( DiffTime, NominalDiffTime, UTCTime (..), secondsToDiffTime )+import Hedgehog ( Gen, Range )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude++genAesonString :: Gen Aeson.Value+genAesonString = Aeson.String <$> Gen.text (Range.constant 0 1024) Gen.unicodeAll++genUTCTime :: Gen UTCTime+genUTCTime = UTCTime <$> genDay <*> genDiffTime+  where+    genDay :: Gen Day+    genDay =+      fromOrdinalDate+        <$> Gen.integral (Range.constant 0 3000)+        <*> Gen.int (Range.constant 1 365)++    genDiffTime :: Gen DiffTime+    genDiffTime = secondsToDiffTime <$> Gen.integral (Range.constant 0 86400)++genNominalDiffTime+  :: Range Integer+  -- ^ Range of seconds.+  -> Gen NominalDiffTime+genNominalDiffTime range = fromInteger <$> Gen.integral range
+ test/Test/Golden.hs view
@@ -0,0 +1,44 @@+module Test.Golden+  ( goldenTestPae+  , goldenTestPaseto+  ) where++import Control.Monad.IO.Class ( liftIO )+import qualified Crypto.Paseto.PreAuthenticationEncoding as PAE+import Crypto.Paseto.Token ( Token (..), toSomeToken )+import Crypto.Paseto.Token.Encoding ( encode )+import Crypto.Paseto.Token.Parser ( parseSomeToken )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as TE+import GHC.Stack ( HasCallStack, withFrozenCallStack )+import Hedgehog ( Property, property, withTests, (===) )+import Hedgehog.Internal.Property ( failWith )+import Prelude++-- | Golden test for PASETO Pre-Authentication Encoding (PAE).+goldenTestPae+  :: HasCallStack+  => [ByteString]+  -> FilePath+  -> Property+goldenTestPae x path = withFrozenCallStack $ withTests 1 . property $ do+  bs <- liftIO (BS.readFile path)+  PAE.encode x === bs+  case PAE.decode bs of+    Left err -> failWith Nothing $ "could not decode: " <> show err+    Right x' -> x === x'++-- | Golden test for the+-- [PASETO message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format).+goldenTestPaseto+  :: HasCallStack+  => Token v p+  -> FilePath+  -> Property+goldenTestPaseto x path = withFrozenCallStack $ withTests 1 . property $ do+  t <- TE.decodeUtf8 <$> liftIO (BS.readFile path)+  encode x === t+  case parseSomeToken t of+    Left err -> failWith Nothing $ "could not decode: " <> show err+    Right x' -> (toSomeToken x) === x'