libjwt-typed (empty) → 0.1
raw patch · 41 files changed
+7941/−0 lines, 41 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, case-insensitive, casing, containers, criterion, data-default, deepseq, either, exceptions, extra, hspec, hspec-core, jose, jwt, lens, libjwt-typed, monad-time, proxied, quickcheck-instances, text, time, transformers, unordered-containers, utf8-string, uuid
Files
- CHANGELOG.md +11/−0
- LICENSE +373/−0
- README.md +540/−0
- bench/Algorithms.hs +197/−0
- bench/Benchmarks.hs +90/−0
- bench/Benchmarks/Data.hs +22/−0
- bench/Benchmarks/Jose.hs +262/−0
- bench/Benchmarks/Libjwt.hs +200/−0
- bench/Env.hs +84/−0
- libjwt-typed.cabal +171/−0
- src/Libjwt/ASCII.hs +16/−0
- src/Libjwt/Classes.hs +538/−0
- src/Libjwt/Decoding.hs +148/−0
- src/Libjwt/Encoding.hs +123/−0
- src/Libjwt/Exceptions.hs +85/−0
- src/Libjwt/FFI/Jsmn.hsc +46/−0
- src/Libjwt/FFI/Jwt.hs +439/−0
- src/Libjwt/FFI/Libjwt.hsc +17/−0
- src/Libjwt/Flag.hs +135/−0
- src/Libjwt/Header.hs +75/−0
- src/Libjwt/JsonByteString.hs +50/−0
- src/Libjwt/Jwt.hs +259/−0
- src/Libjwt/JwtValidation.hs +247/−0
- src/Libjwt/Keys.hs +134/−0
- src/Libjwt/NumericDate.hs +59/−0
- src/Libjwt/Payload.hs +256/−0
- src/Libjwt/PrivateClaims.hs +800/−0
- src/Libjwt/RegisteredClaims.hs +136/−0
- src/Web/Libjwt.hs +301/−0
- src/Web/Libjwt/Tutorial.hs +131/−0
- src/cbits/HsJsonTokenizer.c +49/−0
- src/cbits/jsmn/LICENSE +20/−0
- src/cbits/jsmn/Makefile +36/−0
- src/cbits/jsmn/jsmn.h +471/−0
- test/Env.hs +183/−0
- test/Generators.hs +258/−0
- test/Interop/JWTDecoding.hs +436/−0
- test/Interop/JWTEncoding.hs +287/−0
- test/Interop/JWTHelpers.hs +33/−0
- test/Properties.hs +202/−0
- test/Spec.hs +21/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`libjwt-typed` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.1++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/marcin-rzeznicki/libjwt-typed/releases
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,540 @@+# libjwt-typed++[](https://travis-ci.org/marcin-rzeznicki/libjwt-typed)+[](https://hackage.haskell.org/package/libjwt-typed)+[](http://stackage.org/lts/package/libjwt-typed)+[](http://stackage.org/nightly/package/libjwt-typed)+[](LICENSE)++A Haskell implementation of [JSON Web Token (JWT)](https://jwt.io).++1. [Key features](#key-features)+ 1. [Type-safety](#type-safety)+ 1. [Speed and robustness](#speed-and-robustness)+ 1. [Ease of use](#ease-of-use)+1. [Installation](#installation)+1. [Supported algorithms](#supported-algorithms)+ 1. [Example usage](#example-usage)+ 1. [With secrets (HS256, HS384, HS512)](#with-secrets-hs256-hs384-hs512)+ 1. [With keys](#with-keys)+1. [Usage](#usage)+ 1. [Create a payload](#create-a-payload)+ 1. [Namespaces](#namespaces)+ 1. [Signing a token](#signing-a-token)+ 1. [Decoding a token](#decoding-a-token)+1. [Supported types](#supported-types)+ 1. [Flags](#flags)+1. [Benchmarks](#benchmarks)+ 1. [Signing](#signing)+ 1. [Decoding](#decoding)+1. [Not implemented](#not-implemented)+1. [Idea](#idea)++## Key features++### Type-safety++Above Haskell standard type-safety, the library keeps track of public and private claim names and types. There are no user-facing `HashMap`s in this library! A type of a JWT token might be: `Jwt+ '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, Text)]+ ('SomeNs "https://example.com")`.++From information encoded with precise types, it automatically derives encoders and decoders. It can also work with generic representations such as records.++### Speed and robustness++`libjwt-typed` uses [libjwt](https://github.com/benmcollins/libjwt) for low-level functionality. `libjwt` delegates cryptographic work to either `GnuTLS` or `OpenSSL`. This way, not only the most performance-sensitive features work lightning fast, they are also extremely reliable.+Besides, the library does not depend on any JSON library like `aeson`, but it implements the necessary JSON processing in C via [jsmn](https://github.com/zserge/jsmn) - which makes it even faster.+[Benchmarking](#benchmarks) shows that it can be over 10 times faster than other Haskell JWT libraries.++### Ease of use++The library is designed for frictionless use. It can be easily extended, e.g. to add support for new types or to use custom JSON encodings compatible with other libraries you may already use in your project. Most instances can be derived automatically. The compilation errors are designed to be informational, i.e. you get `Claim "user_name" does not exist in this claim set` from GHC, not some 3 page long instance resolution output.++## Installation++`libjwt-typed` is available on [Hackage](http://hackage.haskell.org/package/libjwt-typed)++You must have `libjwt` (preferrably the latest version) installed on your system and visible to the linker. `libjwt-typed` links to it at compile time. You can configure `libjwt` with `GnuTLS` or `OpenSSL` (it doesn't matter for `lbjwt-typed` which one you chose)++## Supported algorithms++| JWS | Algorithm | Description |+| :---: | :-------: | :--------------------------------- |+| HS256 | HMAC256 | HMAC with SHA-256 |+| HS384 | HMAC384 | HMAC with SHA-384 |+| HS512 | HMAC512 | HMAC with SHA-512 |+| RS256 | RSA256 | RSASSA-PKCS1-v1_5 with SHA-256 |+| RS384 | RSA384 | RSASSA-PKCS1-v1_5 with SHA-384 |+| RS512 | RSA512 | RSASSA-PKCS1-v1_5 with SHA-512 |+| ES256 | ECDSA256 | ECDSA with curve P-256 and SHA-256 |+| ES384 | ECDSA384 | ECDSA with curve P-384 and SHA-384 |+| ES512 | ECDSA512 | ECDSA with curve P-521 and SHA-512 |+++### Example usage++#### With secrets (HS256, HS384, HS512)++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Web.Libjwt ( Alg(HS512) )++hmac512 :: Alg+hmac512 =+ HS512+ "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\+ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\+ \Y2IwMDZhYWY1MjY1OTQgIC0K"+```++A key of the same size as the hash output (for instance, 256 bits for+ "HS256") or larger MUST be used with these algorithms.++#### With keys ++Obtaining or reading keys is beyond the scope of this library. It accepts PEM-encoded RSA/ECDSA keys as `ByteString`s++```haskell+import Web.Libjwt ( Alg(..)+ , EcKeyPair(..)+ , RsaKeyPair(..)+ )+import qualified Data.ByteString.Char8 as C8++rsa2048KeyPair :: RsaKeyPair+rsa2048KeyPair =+ let private = C8.pack $ unlines+ [ "-----BEGIN RSA PRIVATE KEY-----"+ , "MIIEpgIBAAKCAQEAwCXp2P+qboao0tjUyU+D3YI+sgBn8dkGaxOvPFLBFQMNkhbL"+ -- ... + , "-----END RSA PRIVATE KEY-----"+ ]+ public = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D"+ -- ...+ , "-----END PUBLIC KEY-----"+ ]+ in FromRsaPem { privKey = private, pubKey = public }++rs512 :: Alg+rs512 = RS512 rsa2048KeyPair++ecP521KeyPair :: EcKeyPair+ecP521KeyPair =+ let private = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MIHcAgEBBEIAIWLn8LIw+NC3gZJIFemY/Ku5QNNncVjNZiQdICh7KzgHPrjCrdQk"+ -- ...+ , "-----END EC PRIVATE KEY-----"+ ]+ public = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIGbMBAGByqGSM49AgEGBSuBBAAjA4GGAAQBoCA7tBSz6R9DTQM5aq0VtyApXMUm"+ -- ...+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey = private, ecPubKey = public }++es512 :: Alg+es512 = ES512 ecP521KeyPair+```++A key of size 2048 bits or larger MUST be used for RSA algorithms.++The [specification](https://tools.ietf.org/html/rfc7518) defines "the use of ECDSA with the P-256 curve [secp256k1 or prime256v1] and+ the SHA-256 cryptographic hash function, ECDSA with the P-384 curve [secp384r1]+ and the SHA-384 hash function, and ECDSA with the P-521 curve [secp521r1] and the+ SHA-512 hash function."++## Usage ++### Create a payload++Assuming++```haskell+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonomorphismRestriction #-} -- just for sweet and short examples+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++import Web.Libjwt++import Data.ByteString ( ByteString )+import Data.Default+import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Text ( Text )+import Data.Time.Clock ( UTCTime )+import Data.UUID ( UUID )+import GHC.Generics++import Prelude hiding ( exp )++data UserClaims = UserClaims { userId :: UUID+ , userName :: Text+ , isRoot :: Bool+ , createdAt :: UTCTime+ , accounts :: NonEmpty UUID+ }+ deriving stock (Eq, Show, Generic)+```++* Direct style+```haskell++mkPayload UserClaims {..} currentTime =+ let now = fromUTC currentTime+ in def+ { iss = Iss (Just "myApp")+ , aud = Aud ["https://myApp.com"]+ , iat = Iat (Just now)+ , exp = Exp (Just $ now `plusSeconds` 300)+ , privateClaims = toPrivateClaims+ ( #user_name ->> userName+ , #is_root ->> isRoot+ , #user_id ->> userId+ , #created ->> createdAt+ , #accounts ->> accounts+ )+ }++{-+λ> :t mkPayload+mkPayload+ :: UserClaims+ -> UTCTime+ -> Payload+ '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,+ "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]+ 'NoNs +-}++```++* Builder (monoidal) style+```haskell++mkPayload' UserClaims {..} = jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ ( #user_name ->> userName+ , #is_root ->> isRoot+ , #user_id ->> userId+ , #created ->> createdAt+ , #accounts ->> accounts+ )++{-+λ> :t mkPayload'+mkPayload'+ :: MonadTime m =>+ UserClaims+ -> m (Payload+ '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,+ "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]+ 'NoNs)+-}++```++* Generic style+```haskell++instance ToPrivateClaims UserClaims++mkPayload'' = jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ UserClaims { userId = read "5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"+ , userName = "JohnDoe"+ , isRoot = False+ , createdAt = read "2020-07-31 11:45:00 UTC"+ , accounts = read "0bdf91cc-48bb-47f5-b633-920c34bd2352" :| []+ }++```++#### Namespaces++To ensure that private do not collide with claims from other resources, it is recommended to give them globally unique names . This is often done through _namespacing_, i.e. prefixing the names with the URI of a resource you control. In `libjwt-typed` this is handled entirely at the type-level, and you don't need to write any code to handle this case. As you may have noticed, `Payload` types have a component of the type `NoNs`. It tracks the namespace assigned to private claims within this payload. If you change the last example to:++```haskell+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++mkPayload''' =+ jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ $ withNs+ (Ns @"https://myApp.com")+ UserClaims+ { userId = read "5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"+ , userName = "JohnDoe"+ , isRoot = False+ , createdAt = read "2020-07-31 11:45:00 UTC"+ , accounts = read "0bdf91cc-48bb-47f5-b633-920c34bd2352" :| []+ }+```++, you'll notice that the type has changed to accomodate the namespace (becoming `Payload '[...] ('SomeNs "https://myApp.com")`). Consequently, in the generated token `"userId"` becomes `"https://myApp.com/userId"` etc++### Signing a token++```haskell++token :: IO ByteString -- or any other MonadTime instance+token = getToken . sign hmac512 <$> mkPayload''++{-+λ> token+"eyJhbGciOiJIUzUxMiIsInR5cCI6IkpXVCJ9.eyJhY2NvdW50cyI6WyIwYmRmOTFjYy00OGJiLTQ3ZjUtYjYzMy05MjBjMzRiZDIzNTIiXSwiYXVkIjpbImh0dHBzOi8vbXlBcHAuY29tIl0sImNyZWF0ZWRBdCI6IjIwMjAtMDctMzFUMTE6NDU6MDBaIiwiZXhwIjoxNTk5NDk5MDczLCJpYXQiOjE1OTk0OTg3NzMsImlzUm9vdCI6ZmFsc2UsImlzcyI6Im15QXBwIiwidXNlcklkIjoiNWE3YzVjZGQtMzkwOS00NTZiLTlkZDItNmJhODRiZmVlYjI1IiwidXNlck5hbWUiOiJKb2huRG9lIn0.KH4YSODoTxuNLPYCyz0lmoVDHYJpvL8k6fccFugqs-6VcpctXeR4OYyWOZJDi294r6njCqRP15eqYpwrrzKKrQ" +-}++```++Tip: you can inspect the above token in the [JWT debugger](https://jwt.io)++`sign` is a pure function, we only need `Monad` for the `currentTime` used to construct the payload.++### Decoding a token++```haskell++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++type MyJwt+ = Jwt+ '["userId" ->> UUID, "userName" ->> Text, "isRoot" ->> Bool, "createdAt" ->> UTCTime, "accounts" ->> NonEmpty UUID]+ 'NoNs++decodeDoNotUse :: IO (Decoded MyJwt)+decodeDoNotUse = decodeByteString hmac512 =<< token++{-+λ> decode_do_not_use+MkDecoded {getDecoded = Jwt {header = Header {alg = HS512 (MkSecret {reveal = "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2MxYzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5Y2IwMDZhYWY1MjY1OTQgIC0K"}), typ = JWT}, payload = ClaimsSet {iss = Iss (Just "myApp"), sub = Sub Nothing, aud = Aud ["https://myApp.com"], exp = Exp (Just (NumericDate {secondsSinceEpoch = 1599501809})), nbf = Nbf Nothing, iat = Iat (Just (NumericDate {secondsSinceEpoch = 1599501509})), jti = Jti Nothing, privateClaims = (#userId ->> 5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25, #userName ->> "JohnDoe", #isRoot ->> False, #createdAt ->> 2020-07-31 11:45:00 UTC, #accounts ->> (0bdf91cc-48bb-47f5-b633-920c34bd2352 :| []))}}}+-}++```++While the structure of the JWT can be inferred when signing - this obviously is not the case when decoding. `decodeByteString` can't possibly know what you are going to extract from the token, so you need to give it the expected type. It can simply be _type-alias_ like in the example above. Based on this, the correct decoder is dervied. If something goes wrong an exception will be thrown, which you can catch and inspect. ++The result of this function is an instance of `Decoded` type. The JWT stucture wrapped in this type is guaranteed to be correct representation of the requested type with its signature checked according to your algorithm and secret/key.++**IMPORTANT: Your program should always require an instance of the `Validated` type (see below). `Decoded` only means that the signature and the representation are correct, but does not verify that the token has not expired or is not intended for you etc.**++To return decoded **and** validated structure it is better to do++```haskell++decodeAndValidate :: IO (ValidationNEL ValidationFailure (Validated MyJwt))+decodeAndValidate = jwtFromByteString settings mempty hmac512 =<< token+ where settings = Settings { leeway = 5, appName = Just "https://myApp.com" }++{-+λ> decodeAndValidate +Success (MkValid {getValid = Jwt {header = Header {alg = HS512 (MkSecret {reveal = "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2MxYzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5Y2IwMDZhYWY1MjY1OTQgIC0K"}), typ = JWT}, payload = ClaimsSet {iss = Iss (Just "myApp"), sub = Sub Nothing, aud = Aud ["https://myApp.com"], exp = Exp (Just (NumericDate {secondsSinceEpoch = 1599504161})), nbf = Nbf Nothing, iat = Iat (Just (NumericDate {secondsSinceEpoch = 1599503861})), jti = Jti Nothing, privateClaims = (#userId ->> 5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25, #userName ->> "JohnDoe", #isRoot ->> False, #createdAt ->> 2020-07-31 11:45:00 UTC, #accounts ->> (0bdf91cc-48bb-47f5-b633-920c34bd2352 :| []))}}})+ -}++```++JWT validation is monoid. You can append additional validations based on public and private claims, for example `checkIssuer "myApp" <> checkClaim (== True) #isRoot`. You will certainly like the fact that private claims' types are fullly known, so you can operate on type-safe Haskell values (`checkClaim ( > 0) #isRoot` will not compile). The `mempty` validation (the default validation) checks (according to [the rules in the RFC](https://tools.ietf.org/html/rfc7519#section-4.1) ) whether:+* token has not expired (`exp` claim),+* token is ready to use (`nbf` claim),+* token is intended for you (`aud` claim)+ +Time-based validations (all predefined validations for `exp`, `nbf` and `iat` claims) allow for some small leeway (e.g. `leeway = 5` means that the token expired less than 5 seconds ago is still considered to be valid), which can be set in `ValidationSettings`.++Full example with error-handling might look like:+```haskell+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Arrow ( left )+import Control.Exception ( catch+ , displayException+ )+import Data.Either.Validation ( validationToEither )++decodeAndValidateFull :: IO (Either String UserClaims)+decodeAndValidateFull =+ ( left (("Token not valid: " ++) . show)+ . fmap toUserClaims+ . validationToEither+ <$> decodeAndValidate+ )+ `catch` onError+ where+ toUserClaims = fromPrivateClaims . privateClaims . payload . getValid+ onError (e :: SomeDecodeException) =+ return $ Left $ "Cannot decode token " ++ displayException e++{-+λ> decodeAndValidateFull +Right (UserClaims {userId = 5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25, userName = "JohnDoe", isRoot = False, createdAt = 2020-07-31 11:45:00 UTC, accounts = 0bdf91cc-48bb-47f5-b633-920c34bd2352 :| []})+-}++```++## Supported types++The following types are currently supported:+ * ByteString+ * String+ * Text+ * Libjwt.ASCII (for marking strings as ASCII only)+ * Libjwt.JsonByteString (for working with pure JSON)+ * Bool+ * Libjwt.NumericDate (POSIX timestamps)+ * Libjwt.Flag (for simple sum types)+ * Int+ * UUID+ * UTCTime, ZonedTime, LocalTime, Day+ * Maybes of the above types+ * lists of the above types and lists of tuples created from them+ * NonEmpty lists of the above types+ +### Flags++Flags provide a way to automatically encode and decode simple sum types.++```haskell+data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite+ deriving stock (Show, Eq, Generic)++instance AFlag Scope+```++Now, you can use `Flag Scope` in JWT claims, e.g.++```haskell+mkPayload' UserClaims {..} = jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ ( #user_name ->> userName+ , #is_root ->> isRoot+ , #user_id ->> userId+ , #created ->> createdAt+ , #accounts ->> accounts+ , #scope ->> Flag Login+ )+```++## Benchmarks++Full result sets (graphical HTML reports) are available [here](https://github.com/marcin-rzeznicki/libjwt-typed/tree/master/bench/results). ++Code can be found [here](https://github.com/marcin-rzeznicki/libjwt-typed/tree/master/bench). Benchmarking is undoubtedly hard - if you think something can be improved, please make a PR.++The Benchmarks compare `libjwt-typed` to `jose` in different hopefully real-world use cases. All the results below were obtained on a 6-Core Intel Core i7-9750H; 32 GB RAM; GHC 8.10.1 (compiled with -O2; RTS options: -N -ki2k -A512m -n32m); libjwt built with GnuTLS using GCC 10.2.0++### Signing++Measuring going from data to a fully signed, ready to send over-the-wire token++When signing an "empty" token using `SHA-512` i.e. something like+```json+{+ "iat": 1599531131,+ "nbf": 1599531131,+ "exp": 1599531431,+ "sub": "c5caab61-3ee4-49ab-86e6-b6ac292901f7",+ "aud": ["https://example.com"],+ "iss": "benchmarks"+}+```++| what | libjwt | jose | speedup |+| :---: | :----------------------: | :------------------: | :-----: |+| mean | **9.05 μs** (± 278 ns) | 166 μs (± 5.74 μs) | 18x |++For more complex tokens i.e. something like+```json+{+ "iat": 1599531131,+ "nbf": 1599531131,+ "exp": 1599531431,+ "sub": "c5caab61-3ee4-49ab-86e6-b6ac292901f7",+ "aud": ["https://example.com"],+ "iss": "benchmarks",+ "user_name": "E\\129057~[lzR64FhhdhrlUMH0A",+ "is_root": true,+ "client_id": "b659f842-5d78-4da1-9891-8aaa4ac3983b",+ "created": "2020-09-08 02:12:11.099106573 UTC",+ "accounts": [+ ["8aa634fb-8cc4-44cb-84ec-9eb6c78834e1", "k"],+ ["da8b0ff6-a32c-43d0-bd89-1a63273945e0", ")`"],+ ["219f30da-c474-4f23-af6a-495b1034e02f", "J"]+ ],+ "emails": ["0g(B@example.com", "eo@example.com"]+}+```++| what | libjwt | jose | speedup |+| :---: | :-----------------------: | :------------------: | :-----: |+| mean | **35.4 μs** (± 89.9 ns) | 525 μs (± 9.94 μs) | 14x |+++When signing using elliptic-curve cryptography: `ECDSA256` ++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :-------------------: | :-----: |+| mean (simple) | **77.3 μs** (± 833 ns) | 1.18 ms (± 21.6 μs) | 15x |+| mean (complex) | **112 μs** (± 1.17 μs) | 1.54 ms (± 22.0 μs) | 13x |++and `ECDSA512`++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :-------------------: | :-----: |+| mean (simple) | **270 μs** (± 4.74 μs) | 3.94 ms (± 40.7 μs) | 14x |+| mean (complex) | **305 μs** (± 4.19 μs) | 4.31 ms (± 55.5 μs) | 14x |++And finally using the `RSA (RSASSA-PKCS1-v1_5 using SHA-512)`++| what | libjwt | jose | speedup |+| :------------: | :-------------------: | :-----------------------: | :-----: |+| mean (simple) | 1.40 ms (± 13.2 μs) | **1.03 ms** (± 11.9 μs) | 0.7x |+| mean (complex) | 1.44 ms (± 15.0 μs) | **1.37 ms** (± 15.8 μs) | 0.9x |++This is the only time `jose` is faster (congrats!). `libjwt-typed` is slower probably because it doesn't store private key parameters. This is something thaht needs to be improved.++### Decoding++Here going from a `ByteString` token back to the data is measured. When I say "to the data" I mean user-types, not `aeson` values. This is where `libjwt-typed` has considerable leverage as it doesn't use any intermediate form, but I think it is fair as users will eventually have to parse data anyway.++Using `HMAC512`++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :------------------: | :-----: |+| mean (simple) | **9.29 μs** (± 143 ns) | 128 μs (± 3.40 μs) | 13x |+| mean (complex) | **60.0 μs** (± 691 ns) | 390 μs (± 6.12 μs) | 6x |++Using `ECDSA256`++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :-------------------: | :-----: |+| mean (simple) | **189 μs** (± 1.49 μs) | 1.26 ms (± 14.4 μs) | 6x |+| mean (complex) | **244 μs** (± 3.14 μs) | 1.54 ms (± 15.4 μs) | 6x |++Using `ECDSA512`++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :-------------------: | :-----: |+| mean (simple) | **749 μs** (± 8.66 μs) | 4.45 ms (± 75.4 μs) | 5x |+| mean (complex) | **804 μs** (± 9.67 μs) | 4.71 ms (± 53.8 μs) | 5x |++And finally `RSA`++| what | libjwt | jose | speedup |+| :------------: | :----------------------: | :------------------: | :-----: |+| mean (simple) | **39.4 μs** (± 618 ns) | 138 μs (± 3.23 μs) | 3x |+| mean (complex) | **93.5 μs** (± 777 ns) | 399 μs (± 6.33 μs) | 4x |++## Not implemented++* JWT header can only contain `alg` and `typ` (everything else is ignored). This decision is partly because of the belief that you rarely need to complicate the header, and partly because of the limiation of `libjwt` which prevents the header from being checked before decoding (this is done in one step). For this reason, things like selecting keys based on the header cannot be easily implemented.++## Idea++The idea for this lib comes from my talk ["Building a web library using super hard Haskell"](https://www.youtube.com/watch?v=icgl9FuPxKA) at the Haskell Love Conference
+ bench/Algorithms.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings #-}++module Algorithms+ ( hs512+ , rs256+ , rs512+ , es256+ , es512+ , jwkHS512+ , jwkRS512+ , jwkES256+ , jwkES512+ )+where++import Web.Libjwt ( Alg(..)+ , EcKeyPair(..)+ , RsaKeyPair(..)+ )++import qualified Crypto.JOSE.JWA.JWS as Jose+import Crypto.JOSE.JWK ( JWK )+import qualified Crypto.JOSE.JWK as JWK+import Crypto.JOSE.Types ( Base64Integer(..) )++import Data.Aeson ( decode )++import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as C8++import Data.Maybe ( fromJust )++hs512 :: Alg+hs512 =+ HS512+ "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\+ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\+ \Y2IwMDZhYWY1MjY1OTQgIC0K"++rsa2048KeyPair :: RsaKeyPair+rsa2048KeyPair =+ let private = C8.pack $ unlines+ [ "-----BEGIN RSA PRIVATE KEY-----"+ , "MIIEpgIBAAKCAQEAwCXp2P+qboao0tjUyU+D3YI+sgBn8dkGaxOvPFLBFQMNkhbL"+ , "0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclROXocRWUn5s2W3jP5xn7lM4otIpuE"+ , "3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHVEuGMM7oddiB6s3zjwf2h1v0SEiHf"+ , "5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3JcaWW+eDk/UU3jCfCke7R3t2rbD1ZC"+ , "j1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcpd8iz0ZTLaG8Qnm0GsPQjR3PTZYEC"+ , "xEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5YboxQIDAQABAoIBAQCg/OMBsauc8Ovv"+ , "xEX76MglxeM7hgWQ5vFus05lrzwgm686EClxme1QHMv8QszuXzSjuEFs4SQH9K82"+ , "p2z+UgrgqkOXjNoykVvvDgMe4OCuHv4T+dMGO1hTrXfXawKI2Lhg1/1bzX+u5ii9"+ , "mfbsUUixihHKoQvgFfRX/7JfrV50XZ3diwzd8DoEaIgeAIdyhLhVuh2W7wXbOF+l"+ , "aZW7gqCVzTBhC04E/D6eqFqvnkQyHzZPgaaDi4oL7gP8nGpcswlqKSLO5eVkkEHY"+ , "C88nAwU4Q/+qcAf09ijmTLlo07xLrLC0cOf2yQTwLj6ZffzTJ7NSMaPrTdEXThsW"+ , "wAeB/GcBAoGBAOzLST9/zakFGBTkwiLqgNVgEBUoYjB0Z+Fpx4qBLzKZNQP1yNup"+ , "LhC/4pIVQM+ZjOS0Wx7Sh0FTLHFb018quPiAPsKMEC2CW5v7vKwC4zW72/v5UrIw"+ , "pcBzl67nsc53r5Lblol9PU4oCjDzuFMjMbg+EzD3kVp/gxC9bRMwK3zBAoGBAM+7"+ , "nOV80uteB1ZXazccj6g0ANd2AyJY6gHfxD1CopvRReYm36wmG00HQ3jHZPUcsLQp"+ , "dWvWplRFprZlce0jl7HcB/8g5wUkErMop3KK5cA886HxsATNSl6rYghZGALqxm/a"+ , "+v2AKoZThns8QRYL5bsBD4kTQLEIwp7j6sNbBrkFAoGBAL6fL8o0gkUsWqSHO1mM"+ , "WkZrXMcLiW/kZbPqyb3QHUSoXStg818RpInLTwO2pEP7IpcCMdBwPn3yDPb8qv4T"+ , "kHBMHTnUMznPlRvO3aXDdVFOd9sybMYRr31sEJG250aExwx8RYVNEssWJI4fxST4"+ , "UhA1uJFU2uh1efdB5srpnjiBAoGBALTDCPAZAmCVXcUgJMe8LrWrKuBSbL/Cpz4i"+ , "PV0hUuZL4Is5YIEoV7FblLbQq2UvJgRf3zGLgwjp4vvsooo74pB+auby9pReo3cK"+ , "9UqS2wHBCC/vY7+J9CEU+SVSgbZoHWzQHH/iux5QKEGsWOaaS7nCXoZlHnHusYwZ"+ , "v/tmhh8RAoGBAIi3Lbup0AVwougANLXwMLCfT8HxI8Hozdr+Pe0ibTnjfY+BPuy1"+ , "vSgozXao68TwW3u58PcdvfBnfg/7XCK6TXtij48JDu6qw0IiSRxOZ5Ed/GW2P031"+ , "7TfwnjBohjM2O6NRne8qe6Qv5xLagoVKQfa1WhQEFU2bTNLYA/2kv266"+ , "-----END RSA PRIVATE KEY-----"+ ]+ public = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D"+ , "3YI+sgBn8dkGaxOvPFLBFQMNkhbL0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclR"+ , "OXocRWUn5s2W3jP5xn7lM4otIpuE3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHV"+ , "EuGMM7oddiB6s3zjwf2h1v0SEiHf5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3Jc"+ , "aWW+eDk/UU3jCfCke7R3t2rbD1ZCj1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcp"+ , "d8iz0ZTLaG8Qnm0GsPQjR3PTZYECxEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5Ybo"+ , "xQIDAQAB"+ , "-----END PUBLIC KEY-----"+ ]+ in FromRsaPem { privKey = private, pubKey = public }++rs256 :: Alg+rs256 = RS256 rsa2048KeyPair++rs512 :: Alg+rs512 = RS512 rsa2048KeyPair++ecP256KeyPair :: EcKeyPair+ecP256KeyPair =+ let private = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MHcCAQEEINQ0e0KOa3EZSB5RTd2xBuO3O7NNFietDIWl+B+R38LuoAoGCCqGSM49"+ , "AwEHoUQDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FNlsrCnaXRoJUVdOYZldzb4po2"+ , "uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+ , "-----END EC PRIVATE KEY-----"+ ]+ public = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MFkwEwYHKoZIzj0CAQYIKoZIzj0DAQcDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FN"+ , "lsrCnaXRoJUVdOYZldzb4po2uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey = private, ecPubKey = public }++es256 :: Alg+es256 = ES256 ecP256KeyPair++ecP521KeyPair :: EcKeyPair+ecP521KeyPair =+ let private = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MIHcAgEBBEIAIWLn8LIw+NC3gZJIFemY/Ku5QNNncVjNZiQdICh7KzgHPrjCrdQk"+ , "2HNAZ+7r5biSu07Kucvn7OLbubL8iFykX8GgBwYFK4EEACOhgYkDgYYABAGgIDu0"+ , "FLPpH0NNAzlqrRW3IClcxSZt043iTdwLTmbMj51epCDDPb04jfdDWg58pQqXRKEI"+ , "xRUJbv/6aJimWkfkvwBsHhdkIdXSTID9wKTaCSkeGAqGdzjkBdTMA8sfEujYDtHt"+ , "FoCrBx31I4jnh2yX1WNa9oycus38E6IzWeTdq547aA=="+ , "-----END EC PRIVATE KEY-----"+ ]+ public = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIGbMBAGByqGSM49AgEGBSuBBAAjA4GGAAQBoCA7tBSz6R9DTQM5aq0VtyApXMUm"+ , "bdON4k3cC05mzI+dXqQgwz29OI33Q1oOfKUKl0ShCMUVCW7/+miYplpH5L8AbB4X"+ , "ZCHV0kyA/cCk2gkpHhgKhnc45AXUzAPLHxLo2A7R7RaAqwcd9SOI54dsl9VjWvaM"+ , "nLrN/BOiM1nk3aueO2g="+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey = private, ecPubKey = public }++es512 :: Alg+es512 = ES512 ecP521KeyPair++jwkHS512 :: (Jose.Alg, JWK)+jwkHS512 =+ ( Jose.HS512+ , JWK.fromOctets+ ("MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\+ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\+ \Y2IwMDZhYWY1MjY1OTQgIC0K" :: ByteString+ )+ )++jwkRS512 :: (Jose.Alg, JWK)+jwkRS512 =+ let+ rsaN =+ Base64Integer+ 21071666595382654004815830003291135226213375605579463114213666885162970050362260641378848210839698813616018661779188948656905472806115096313509733841002972548378762928254795013919788232987376549887236239308783399460589276366127380239651445012871883061369461005966640738975889383298437567168811300366234946027700641546838113190525302696713965296806901671241628461497496694989297235831876004199661653018743316900741288781592524963173982960567805012775229890256541370866292114269655407207451318367259794670451071683128223951472325608349088189586629857137365222371124466180904001530025257089565415545120432511743113512473+ rsaE = Base64Integer 65537+ rsaD =+ Base64Integer+ 19950515163090981903334334066316965085166241303785734565771366254548763166226380102805400483430784310921677189425800300046706205465911496196854890898793573807572855634194577576235147471762007948494789335018539297443117088034517966093510111281393721774844363572031525059942535304235287715989818593889327836199410763613773297881984598831126309157462916917948945881897383450666311618062870578744825198060209947343612529835724282995784470652634835141123292719604629163927545705270795831312767908907697441504682913850869791489990390358315243559993131306656391164462063211130191489451712836337004003290172594730408707046473+ rsaP =+ Base64Integer+ 153349769578169153058871716836180422106339541427708058036596622771192505561541419690995294407950382598829412251529799333727105395997138736446264960660733442117439252140820758012973354169242686630895924852681492970479214660745044040197294406602779131107543820213877788006961751859321067912409389608332161173411+ rsaQ =+ Base64Integer+ 137409183289587497714220607669486353304153007305941898031265596693236647869265299751218993497626466629738881077301044167807443992262379561682756469245629338638948544863207793485455072238568804673037755612969639524433881085993953622535671527176972751290168290320944672117795106277492834923153567627878390957843+ rsaDp =+ Base64Integer+ 153300631760430447408411117387722912777804009890256208406330230823465343155316045172578050695504482450293845813376052201786243452159063452050192946925379742645622320876115976959243820616630359297950431247208152546712791670558193163214152926484088035058697238584805791523324322669870135730189260563948454635353+ rsaDq =+ Base64Integer+ 32368325855999691620186119920068515835474832946108778580140657670479078532824476212815948572811654360588810077839594730650034642302006739296250886861071238077850491105760134211643123811267302539670062272502941773016925648192237301443546348422388960959726842332953047105520863797731577361546069808492707929981+ rsaQi =+ Base64Integer+ 27571505766428475328455285089562516511258707017324580945158490959713515982603670667108107072333234933006284329274187908422010559614331442880924878733162609474802580561043028467939476205597975399753477385845907675851008053322874093082221184241483472466527639166322448897870481530431990331215794498080587118813+ in+ ( Jose.RS512+ , JWK.fromKeyMaterial+ $ JWK.RSAKeyMaterial+ $ JWK.RSAKeyParameters rsaN rsaE+ $ Just+ $ JWK.RSAPrivateKeyParameters rsaD+ $ Just+ $ JWK.RSAPrivateKeyOptionalParameters rsaP rsaQ rsaDp rsaDq rsaQi Nothing+ )+++jwkES256 :: (Jose.Alg, JWK)+jwkES256 =+ ( Jose.ES256+ , JWK.fromKeyMaterial+ $ fromJust+ $ decode+ "{\"crv\":\"P-256\",\"d\":\"2cnW8FRZ_fS_K_MWQ6SaFR45EXXMPvglEkHcb2rCqqw\",\"x\":\"I0EbOl87INBId_qblVunGENMHERnsXP39DV6wfJAvx8\",\"kty\":\"EC\",\"y\":\"on_b2TDmYusX6cOc07BoAfelzdKdMRHB7R8gwRCFhkA\"}"+ )++jwkES512 :: (Jose.Alg, JWK)+jwkES512 =+ ( Jose.ES512+ , JWK.fromKeyMaterial+ $ fromJust+ $ decode+ "{\"crv\":\"P-521\",\"d\":\"AD1kHuRIRTWjb0YKg9HDINWjLH_TprOmAGis5puv2tPaOZ7666JNkebxMR0CG8kz8LezWPJA069otTMDtlQZrkCL\",\"x\":\"APrcS4DmgcxjPCVUBPOE-T2iO4eWt4GFNFODHDQVY_WMF3WPsFHvmtBaTdbCYEltzEacgBSD1e0fxnHM9mihMAzC\",\"kty\":\"EC\",\"y\":\"ARSXmiJY-ed-3MMWw6F5WfYyw1gZ_hGY0Egqn2YZEKE62kgTYBF6GJ8I4V-Ix1_DciwCGUSbXe1OUIPDDBcRx4Hk\"}"+ )
+ bench/Benchmarks.hs view
@@ -0,0 +1,90 @@++module Main+ ( main+ )+where++import Algorithms+import Benchmarks.Jose as Jose+import Benchmarks.Libjwt as My++import Criterion hiding ( benchmark )+import Criterion.Main ( defaultMain )++main :: IO ()+main = defaultMain+ [ bgroup+ "signing"+ [ bgroup+ "HMAC512"+ [ my $ mySigning <*> pure hs512+ , jose $ joseSigning <*> pure jwkHS512+ ]+ , bgroup+ "RSA512"+ [ my $ mySigning <*> pure rs512+ , jose $ joseSigning <*> pure jwkRS512+ ]+ , bgroup+ "ECDSA256"+ [ my $ mySigning <*> pure es256+ , jose $ joseSigning <*> pure jwkES256+ ]+ , bgroup+ "ECDSA512"+ [ my $ mySigning <*> pure es512+ , jose $ joseSigning <*> pure jwkES512+ ]+ ]+ , bgroup+ "decoding"+ [ bgroup+ "HMAC512"+ [ my $ myDecoding <*> pure hs512+ , jose $ joseDecoding <*> pure jwkHS512+ ]+ , bgroup+ "RSA512"+ [ my $ myDecoding <*> pure rs512+ , jose $ joseDecoding <*> pure jwkRS512+ ]+ , bgroup+ "ECDSA256"+ [ my $ myDecoding <*> pure es256+ , jose $ joseDecoding <*> pure jwkES256+ ]+ , bgroup+ "ECDSA512"+ [ my $ myDecoding <*> pure es512+ , jose $ joseDecoding <*> pure jwkES512+ ]+ ]+ ]+ where+ jose = bgroup "jose"+ joseSigning =+ [ Jose.signSimple+ , Jose.signCustomClaims+ , Jose.signCustomClaimsWithNs+ , Jose.signComplexClaims+ ]+ joseDecoding =+ [ Jose.decodeSimple+ , Jose.decodeCustomClaims+ , Jose.decodeCustomClaimsWithNs+ , Jose.decodeComplexClaims+ ]++ my = bgroup "libjwt"+ mySigning =+ [ My.signSimple+ , My.signCustomClaims+ , My.signWithNs+ , My.signComplexCustomClaims+ ]+ myDecoding =+ [ My.decodeSimple+ , My.decodeCustomClaims+ , My.decodeWithNs+ , My.decodeComplexCustomClaims+ ]
+ bench/Benchmarks/Data.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Benchmarks.Data+ ( Scope(..)+ )+where++import Web.Libjwt ( AFlag )++import Data.Aeson ( FromJSON+ , ToJSON+ )++import GHC.Generics++data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite+ deriving stock (Show, Eq, Generic)++instance AFlag Scope+instance ToJSON Scope+instance FromJSON Scope
+ bench/Benchmarks/Jose.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Benchmarks.Jose+ ( signSimple+ , decodeSimple+ , signCustomClaims+ , decodeCustomClaims+ , signCustomClaimsWithNs+ , decodeCustomClaimsWithNs+ , signComplexClaims+ , decodeComplexClaims+ )+where++import Benchmarks.Data+import Env+++import Control.Lens.Operators ( (?~)+ , (&)+ , (.~)+ , (^?)+ )+import Control.Lens.Combinators ( view )++import Control.Monad.Trans.Except ( runExceptT+ , except+ )++import Criterion ( Benchmark+ , bench+ , env+ , nfAppIO+ , whnfAppIO+ )++import Crypto.JOSE.JWK+import Crypto.JWT++import Data.Aeson ( Value+ , Result(..)+ , toJSON+ , fromJSON+ )++import Data.ByteString ( ByteString )+import Data.ByteString.Lazy ( toStrict+ , fromStrict+ )++import Data.HashMap.Strict ( HashMap+ , (!)+ )++import Data.Text ( Text )+import qualified Data.Text as T++import Data.Time.Clock ( UTCTime )++import Data.UUID ( UUID )+import Data.List.NonEmpty ( NonEmpty )+++doSign :: Alg -> JWK -> ClaimsSet -> IO ByteString+doSign a k claims =+ either (fail . (show :: JWTError -> String))+ (return . toStrict . encodeCompact)+ =<< runExceptT (signClaims k (newJWSHeader ((), a)) claims)++prepareToken :: (BenchEnv -> ClaimsSet) -> Alg -> JWK -> IO ByteString+prepareToken f a k = localEnv >>= doSign a k . f++decodeJson :: (HashMap Text Value -> Result b) -> ClaimsSet -> Either JWTError b+decodeJson f claimsSet = case f (view unregisteredClaims claimsSet) of+ Success d -> Right d+ Error str -> Left $ JWTClaimsSetDecodeError str++++baseClaimsSet :: BenchEnv -> ClaimsSet+baseClaimsSet LocalEnv {..} =+ let _subject = subject ^? stringOrUri+ _iat = NumericDate currentTimeUtc+ _exp = NumericDate someFutureTimeUtc+ in emptyClaimsSet+ & claimIss+ ?~ "benchmarks"+ & claimSub+ .~ _subject+ & claimAud+ ?~ Audience ["https://example.com"]+ & claimIat+ ?~ _iat+ & claimExp+ ?~ _exp+ & claimNbf+ ?~ _iat++signSimple :: (Alg, JWK) -> Benchmark+signSimple (a, k) = env localEnv $ bench "simple" . nfAppIO benchmark+ where benchmark = doSign a k . baseClaimsSet++decodeSimple :: (Alg, JWK) -> Benchmark+decodeSimple (a, k) =+ env (prepareToken baseClaimsSet a k) $ bench "simple" . whnfAppIO benchmark+ where+ benchmark :: ByteString -> IO (Either JWTError ClaimsSet)+ benchmark token =+ runExceptT+ $ decodeCompact (fromStrict token)+ >>= verifyClaims (validation & issuerPredicate .~ (== "benchmarks")) k++++mkCustomClaims :: BenchEnv -> ClaimsSet+mkCustomClaims e@LocalEnv {..} =+ addClaim "scope" (toJSON Login)+ $ addClaim "created" (toJSON currentTimeUtc)+ $ addClaim "clientId" (toJSON uuid)+ $ addClaim "isRoot" (toJSON flipBit)+ $ addClaim "userName" (toJSON shortPrintableText)+ $ baseClaimsSet e++signCustomClaims :: (Alg, JWK) -> Benchmark+signCustomClaims (a, k) =+ env localEnv $ bench "custom-claims" . nfAppIO benchmark+ where benchmark = doSign a k . mkCustomClaims++decodeCustomClaims :: (Alg, JWK) -> Benchmark+decodeCustomClaims (a, k) =+ env (prepareToken mkCustomClaims a k)+ $ bench "custom-claims"+ . whnfAppIO benchmark+ where+ benchmark+ :: ByteString -> IO (Either JWTError (Text, Bool, UUID, UTCTime, Scope))+ benchmark token =+ runExceptT+ $ decodeCompact (fromStrict token)+ >>= verifyClaims (validation & issuerPredicate .~ (== "benchmarks")) k+ >>= except+ . decodeJson decodeData++ decodeData claims =+ (,,,,)+ <$> fromJSON (claims ! "userName")+ <*> fromJSON (claims ! "isRoot")+ <*> fromJSON (claims ! "clientId")+ <*> fromJSON (claims ! "created")+ <*> fromJSON (claims ! "scope")++++mkCustomClaimsWithNs :: Text -> BenchEnv -> ClaimsSet+mkCustomClaimsWithNs ns e@LocalEnv {..} =+ addClaim (withNs "scope") (toJSON Login)+ $ addClaim (withNs "created") (toJSON currentTimeUtc)+ $ addClaim (withNs "clientId") (toJSON uuid)+ $ addClaim (withNs "isRoot") (toJSON flipBit)+ $ addClaim (withNs "userName") (toJSON shortPrintableText)+ $ baseClaimsSet e+ where withNs = T.append ns++signCustomClaimsWithNs :: (Alg, JWK) -> Benchmark+signCustomClaimsWithNs (a, k) =+ env localEnv $ bench "custom-claims-with-ns" . nfAppIO benchmark+ where+ benchmark = doSign a k . mkCustomClaimsWithNs "https://www.example.com/test"++decodeCustomClaimsWithNs :: (Alg, JWK) -> Benchmark+decodeCustomClaimsWithNs (a, k) =+ env (prepareToken (mkCustomClaimsWithNs "https://www.example.com/test") a k)+ $ bench "custom-claims-with-ns"+ . whnfAppIO benchmark+ where+ benchmark+ :: ByteString -> IO (Either JWTError (Text, Bool, UUID, UTCTime, Scope))+ benchmark token =+ runExceptT+ $ decodeCompact (fromStrict token)+ >>= verifyClaims (validation & issuerPredicate .~ (== "benchmarks")) k+ >>= except+ . decodeJson (decodeData "https://www.example.com/test")++ decodeData ns claims =+ (,,,,)+ <$> fromJSON (claims ! withNs "userName")+ <*> fromJSON (claims ! withNs "isRoot")+ <*> fromJSON (claims ! withNs "clientId")+ <*> fromJSON (claims ! withNs "created")+ <*> fromJSON (claims ! withNs "scope")+ where withNs = T.append ns++++mkComplexClaims :: BenchEnv -> ClaimsSet+mkComplexClaims e@LocalEnv {..} =+ addClaim "emails" (toJSON emailsList)+ $ addClaim+ "scopes"+ (toJSON+ [Login, Extended, UserRead, UserWrite, AccountRead, AccountWrite]+ )+ $ addClaim "accounts" (toJSON accountList)+ $ addClaim "created" (toJSON currentTimeUtc)+ $ addClaim "client_id" (toJSON uuid)+ $ addClaim "is_root" (toJSON flipBit)+ $ addClaim "user_name" (toJSON shortPrintableText)+ $ baseClaimsSet e++signComplexClaims :: (Alg, JWK) -> Benchmark+signComplexClaims (a, k) =+ env localEnv $ bench "complex-claims" . nfAppIO benchmark+ where benchmark = doSign a k . mkComplexClaims++decodeComplexClaims :: (Alg, JWK) -> Benchmark+decodeComplexClaims (a, k) =+ env (prepareToken mkComplexClaims a k)+ $ bench "complex-claims"+ . whnfAppIO benchmark+ where+ benchmark+ :: ByteString+ -> IO+ ( Either+ JWTError+ ( Text+ , Bool+ , UUID+ , UTCTime+ , NonEmpty (UUID, Text)+ , [Scope]+ , [String]+ )+ )+ benchmark token =+ runExceptT+ $ decodeCompact (fromStrict token)+ >>= verifyClaims (validation & issuerPredicate .~ (== "benchmarks")) k+ >>= except+ . decodeJson decodeData++ decodeData claims =+ (,,,,,,)+ <$> fromJSON (claims ! "user_name")+ <*> fromJSON (claims ! "is_root")+ <*> fromJSON (claims ! "client_id")+ <*> fromJSON (claims ! "created")+ <*> fromJSON (claims ! "accounts")+ <*> fromJSON (claims ! "scopes")+ <*> fromJSON (claims ! "emails")++++validation :: JWTValidationSettings+validation =+ defaultJWTValidationSettings (== "https://example.com")+ & jwtValidationSettingsAllowedSkew+ .~ 5++
+ bench/Benchmarks/Libjwt.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Benchmarks.Libjwt+ ( signSimple+ , signCustomClaims+ , signWithNs+ , signComplexCustomClaims+ , decodeSimple+ , decodeCustomClaims+ , decodeWithNs+ , decodeComplexCustomClaims+ )+where++import Web.Libjwt+import Benchmarks.Data+import Env++import Criterion ( Benchmark+ , bench+ , env+ , nf+ , whnfAppIO+ )++import Data.ByteString ( ByteString )++import Data.Default++import Data.List.NonEmpty ( NonEmpty )++import Data.Text ( Text )++import Data.Time.Clock ( UTCTime )++import Data.UUID ( UUID )++import Prelude hiding ( exp )++basePayload :: BenchEnv -> Payload Empty 'NoNs+basePayload LocalEnv {..} = def { iss = Iss (Just "benchmarks")+ , aud = Aud ["https://example.com"]+ , sub = Sub (Just subject)+ , iat = Iat (Just $ fromPOSIX currentTime)+ , exp = Exp (Just $ fromPOSIX someFutureTime)+ , nbf = Nbf (Just $ fromPOSIX currentTime)+ }++prepareToken+ :: Encode (PrivateClaims pc ns)+ => Alg+ -> (Alg -> BenchEnv -> Jwt pc ns)+ -> IO ByteString+prepareToken a jwt = getToken . signJwt . jwt a <$> localEnv++++type SimpleJwt = Jwt Empty 'NoNs++mkSimpleJwt :: Alg -> BenchEnv -> SimpleJwt+mkSimpleJwt a e = Jwt { header = Header a JWT, payload = basePayload e }++signSimple :: Alg -> Benchmark+signSimple a = env localEnv $ bench "simple" . nf benchmark+ where benchmark = getToken . signJwt . mkSimpleJwt a++decodeSimple :: Alg -> Benchmark+decodeSimple a =+ env (prepareToken a mkSimpleJwt) $ bench "simple" . whnfAppIO benchmark+ where+ benchmark :: ByteString -> IO (ValidationNEL ValidationFailure SimpleJwt)+ benchmark =+ fmap (fmap getValid)+ . jwtFromByteString validationSettings (checkIssuer "benchmarks") a++++type CustomJwt+ = Jwt+ '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, "created" ->> UTCTime, "scope" ->> Flag Scope]+ 'NoNs++mkCustomJwt :: Alg -> BenchEnv -> CustomJwt+mkCustomJwt a e@LocalEnv {..} = Jwt+ { header = Header a JWT+ , payload = (basePayload e)+ { privateClaims = toPrivateClaims+ ( #userName ->> shortPrintableText+ , #isRoot ->> flipBit+ , #clientId ->> uuid+ , #created ->> currentTimeUtc+ , #scope ->> Flag Login+ )+ }+ }++signCustomClaims :: Alg -> Benchmark+signCustomClaims a = env localEnv $ bench "custom-claims" . nf benchmark+ where benchmark = getToken . signJwt . mkCustomJwt a++decodeCustomClaims :: Alg -> Benchmark+decodeCustomClaims a =+ env (prepareToken a mkCustomJwt) $ bench "custom-claims" . whnfAppIO benchmark+ where+ benchmark+ :: ByteString -> IO (ValidationNEL ValidationFailure (Validated CustomJwt))+ benchmark = jwtFromByteString validationSettings (checkIssuer "benchmarks") a++++type CustomJwtWithNs+ = Jwt+ '["userName" ->> Text, "isRoot" ->> Bool, "clientId" ->> UUID, "created" ->> UTCTime, "scope" ->> Flag Scope]+ ( 'SomeNs "https://www.example.com/test")++mkCustomJwtWithNs :: Alg -> BenchEnv -> CustomJwtWithNs+mkCustomJwtWithNs a e@LocalEnv {..} = Jwt+ { header = Header a JWT+ , payload = (basePayload e)+ { privateClaims = toPrivateClaims $ withNs+ (Ns @"https://www.example.com/test")+ ( #userName ->> shortPrintableText+ , #isRoot ->> flipBit+ , #clientId ->> uuid+ , #created ->> currentTimeUtc+ , #scope ->> Flag Login+ )+ }+ }++signWithNs :: Alg -> Benchmark+signWithNs a = env localEnv $ bench "custom-claims-with-ns" . nf benchmark+ where benchmark = getToken . signJwt . mkCustomJwtWithNs a++decodeWithNs :: Alg -> Benchmark+decodeWithNs a =+ env (prepareToken a mkCustomJwtWithNs)+ $ bench "custom-claims-with-ns"+ . whnfAppIO benchmark+ where+ benchmark+ :: ByteString+ -> IO (ValidationNEL ValidationFailure (Validated CustomJwtWithNs))+ benchmark = jwtFromByteString validationSettings (checkIssuer "benchmarks") a++++type ComplexJwt+ = Jwt+ '["user_name" ->> Text, "is_root" ->> Bool, "client_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, Text), "scopes" ->> [Flag Scope], "emails" ->> [String]]+ 'NoNs++mkComplexJwt :: Alg -> BenchEnv -> ComplexJwt+mkComplexJwt a e@LocalEnv {..} = Jwt+ { header = Header a JWT+ , payload = (basePayload e)+ { privateClaims = toPrivateClaims+ ( #user_name ->> shortPrintableText+ , #is_root ->> flipBit+ , #client_id ->> uuid+ , #created ->> currentTimeUtc+ , #accounts ->> accountList+ , #scopes+ ->> [ Flag Login+ , Flag Extended+ , Flag UserRead+ , Flag UserWrite+ , Flag AccountRead+ , Flag AccountWrite+ ]+ , #emails ->> emailsList+ )+ }+ }++signComplexCustomClaims :: Alg -> Benchmark+signComplexCustomClaims a =+ env localEnv $ bench "complex-claims" . nf benchmark+ where benchmark = getToken . signJwt . mkComplexJwt a++decodeComplexCustomClaims :: Alg -> Benchmark+decodeComplexCustomClaims a =+ env (prepareToken a mkComplexJwt)+ $ bench "complex-claims"+ . whnfAppIO benchmark+ where+ benchmark+ :: ByteString -> IO (ValidationNEL ValidationFailure (Validated ComplexJwt))+ benchmark = jwtFromByteString validationSettings (checkIssuer "benchmarks") a++++validationSettings :: ValidationSettings+validationSettings =+ defaultValidationSettings { appName = Just "https://example.com", leeway = 5 }
+ bench/Env.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Env where++import Control.DeepSeq ( NFData )++import Control.Monad ( replicateM )+import Control.Applicative ( liftA2 )++import Data.Char ( isPrint )+import Data.List.NonEmpty+import qualified Data.List.NonEmpty as NEL++import Data.Text ( Text )+import qualified Data.Text as T++import Data.Time.Clock ( UTCTime )+import Data.Time.Clock.POSIX ( POSIXTime+ , getPOSIXTime+ , posixSecondsToUTCTime+ )++import Data.UUID ( UUID )+import qualified Data.UUID as UUID+import qualified Data.UUID.V4 as UUIDV4++import GHC.Generics++import Test.QuickCheck++data BenchEnv = LocalEnv { uuid :: UUID+ , subject :: String+ , currentTime :: POSIXTime+ , currentTimeUtc :: UTCTime+ , someFutureTime :: POSIXTime+ , someFutureTimeUtc :: UTCTime+ , shortPrintableText :: Text+ , flipBit :: Bool+ , accountList :: NonEmpty (UUID, Text)+ , emailsList :: [String]+ }+ deriving stock (Show, Generic)++instance NFData BenchEnv++localEnv :: IO BenchEnv+localEnv = do+ unixTimeNow <- getPOSIXTime+ let future = unixTimeNow + 300+ LocalEnv+ <$> UUIDV4.nextRandom+ <*> (UUID.toString <$> UUIDV4.nextRandom)+ <*> pure unixTimeNow+ <*> pure (posixSecondsToUTCTime unixTimeNow)+ <*> pure future+ <*> pure (posixSecondsToUTCTime future)+ <*> generate genShortPrintableText+ <*> generate arbitrary+ <*> exampleAccountsList+ <*> exampleEmailsList++genShortPrintableText :: Gen Text+genShortPrintableText =+ T.pack+ . getPrintableString+ <$> arbitrary+ `suchThat` (not . null . getPrintableString)++genShortASCIIString :: Gen ASCIIString+genShortASCIIString =+ arbitrary+ `suchThat` (\(ASCIIString ascii) -> not (null ascii) && all isPrint ascii)++exampleAccountsList :: IO (NonEmpty (UUID, Text))+exampleAccountsList = NEL.fromList+ <$> replicateM 4 (liftA2 (,) UUIDV4.nextRandom $ generate genShortASCIIText)+ where genShortASCIIText = T.pack . getASCIIString <$> genShortASCIIString++exampleEmailsList :: IO [String]+exampleEmailsList = replicateM+ 2+ (generate $ (++ "@example.com") . getASCIIString <$> genShortASCIIString)+
+ libjwt-typed.cabal view
@@ -0,0 +1,171 @@+cabal-version: 2.4+name: libjwt-typed+version: 0.1+synopsis: A Haskell implementation of JSON Web Token (JWT)+description: A Haskell implementation of JSON Web Token (JWT)+ .+ = Key features+ .+ == Type-safety+ .+ Above Haskell standard type-safety, the library keeps track of public and private claim names and types. There are no user-facing @HashMap@s in this library! + A type of a JWT token might be: @Jwt '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, Text)] ('SomeNs "https://example.com")@.++ From information encoded with precise types, it automatically derives encoders and decoders. It can also work with generic representations such as records.+ .+ == Speed and robustness+ .+ @libjwt-typed@ uses [libjwt](https://github.com/benmcollins/libjwt) for low-level functionality. @libjwt@ delegates cryptographic work to either @GnuTLS@ or @OpenSSL@.+ This way, not only the most performance-sensitive features work lightning fast, they are also extremely reliable.+ Besides, the library does not depend on any JSON library like @aeson@, but it implements the necessary JSON processing in C via [jsmn](https://github.com/zserge/jsmn) - which makes it even faster. Benchmarking shows that it can be over 10 times faster than other Haskell JWT libraries.+ .+ == Ease of use+ .+ The library is designed for frictionless use.+ It can be easily extended, e.g. to add support for new types or to use custom JSON encodings compatible with other libraries you may already use in your project. Most instances can be derived automatically.+ The compilation errors are designed to be informational, i.e. you get @Claim "user_name" does not exist in this claim set@ from GHC, not some 3 page long instance resolution output.+ .+ = Installation+ .+ You must have [libjwt](https://github.com/benmcollins/libjwt) (preferrably the latest version) installed on your system and visible to the linker.+ .+ @libjwt-typed@ links to it at compile time. + You can configure @libjwt@ with @GnuTLS@ or @OpenSSL@+ .+ Please see the full [README](https://github.com/marcin-rzeznicki/libjwt-typed) or browse the docs for more details.+homepage: https://github.com/marcin-rzeznicki/libjwt-typed+bug-reports: https://github.com/marcin-rzeznicki/libjwt-typed/issues+license: MPL-2.0+license-files: LICENSE+ src/cbits/jsmn/LICENSE+author: Marcin Rzeźnicki+maintainer: Marcin Rzeźnicki <marcin.rzeznicki@gmail.com>+copyright: 2020 Marcin Rzeźnicki+category: Web+build-type: Simple+extra-source-files: src/cbits/jsmn/jsmn.h+ src/cbits/jsmn/Makefile+extra-doc-files: README.md+ CHANGELOG.md+tested-with: GHC == 8.8.3+ GHC == 8.10.1++source-repository head+ type: git+ location: https://github.com/marcin-rzeznicki/libjwt-typed.git++common common-options+ build-depends: base >= 4.13.0.0 && < 4.15,+ bytestring ^>= 0.10.10.0,+ exceptions ==0.10.4,+ either ^>= 5.0.1.1,+ transformers ^>= 0.5.6.2,+ uuid >= 1.3,+ text >= 1.2.3.2 && < 1.2.5,+ time >=1.9 && < 1.10,+ monad-time ==0.3.*,+ data-default >= 0.2 && < 1.0,+ extra ^>= 1.7,+ + ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -fdefer-typed-holes+ if impl(ghc >= 8.0)+ ghc-options: -Wredundant-constraints+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies++ default-language: Haskell2010++library+ import: common-options+ hs-source-dirs: src+ build-depends: unordered-containers ^>= 0.2.10.0,+ utf8-string ^>= 1.0.1.1,+ proxied ==0.3.*,+ casing ^>= 0.1.4.1,+ case-insensitive >= 1.2.0.0+ exposed-modules: Web.Libjwt+ Libjwt.Jwt+ Libjwt.Exceptions+ Libjwt.Header+ Libjwt.RegisteredClaims+ Libjwt.Payload+ Libjwt.JwtValidation+ Libjwt.ASCII+ Libjwt.NumericDate+ Libjwt.Flag+ Libjwt.PrivateClaims+ Libjwt.Classes+ Libjwt.Encoding+ Libjwt.Decoding+ Libjwt.Keys+ Libjwt.JsonByteString+ Libjwt.FFI.Jwt+ other-modules: Libjwt.FFI.Jsmn+ Libjwt.FFI.Libjwt+ Web.Libjwt.Tutorial+ cc-options: -DJSMN_STATIC + -DJSMN_PARENT_LINKS + -DJSMN_STRICT + -march=native + -mtune=native + -O2 + -fno-plt+ include-dirs: src/cbits/jsmn+ c-sources: src/cbits/HsJsonTokenizer.c+ extra-libraries: jwt++test-suite libjwt-typed-test+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Env+ Generators+ Properties+ Interop.JWTHelpers+ Interop.JWTEncoding+ Interop.JWTDecoding+ build-depends: libjwt-typed,+ jwt >= 0.10.0,+ containers,+ aeson,+ hspec ==2.7.*,+ hspec-core ==2.7.*,+ QuickCheck >= 2.13.2 && < 2.15,+ quickcheck-instances >= 0.3.14+ ghc-options: -threaded+ -rtsopts+ "-with-rtsopts=-N -A64m -n4m -ki2k"++benchmark libjwt-typed-benchmark+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Benchmarks.hs+ other-modules: Env+ Algorithms+ Benchmarks.Libjwt+ Benchmarks.Jose+ Benchmarks.Data+ build-depends: libjwt-typed,+ criterion,+ QuickCheck >= 2.13.2 && < 2.15,+ jose >= 0.8.3,+ lens,+ aeson,+ unordered-containers,+ deepseq >= 1.4.4.0+ ghc-options: -O2+ -threaded+ -rtsopts+ "-with-rtsopts=-N -s -ki2k -A512m -n32m"
+ src/Libjwt/ASCII.hs view
@@ -0,0 +1,16 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE DerivingStrategies #-}++-- | ASCII character string+module Libjwt.ASCII+ ( ASCII(..)+ )+where++-- | Represents a string consisting of only ASCII characters. +-- JWT encoding and decoding can safely skip conversion to/from UTF-8 for these values+newtype ASCII = ASCII { getASCII :: String}+ deriving stock (Eq, Ord, Read, Show)
+ src/Libjwt/Classes.hs view
@@ -0,0 +1,538 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | The classes in this module are responsible for encoding and decoding values into JWT objects.+--+-- = Encoding+--+-- The encoders are divided into three groups:+--+-- * /Native/ - types: ByteString, Bool, Int, NumericDate and 'JsonByteString'.+-- They are encoded by simply calling the appropriate FFI function+-- * /Derived/ - types for which there is an instance of 'JwtRep'.+-- They are converted via 'rep' (transitively) to something we know how to encode+-- * /Specialized/ - 'Maybe' and lists+--+-- == JwtRep typeclass and derived encoders+--+-- This typeclass converts a value to its encodable representation. E.g.,+-- to encode 'UUID' we first convert it to something we know how to encode (ByteString).+-- +-- @+-- instance 'JwtRep' ByteString UUID where+-- rep = UUID.toASCIIBytes+-- @+--+-- This is an example of /derived/ encoder that calls 'rep' and then uses a different encoder (native) to perform the actual encoding.+-- This is sufficent to encode any single 'UUID' as 'ByteString' is natively supported.+-- Native encoders automatically take care of converting values to JSON format (escaping, quoting, UTF-8 encoding etc).+--+-- You can use the same method to extend the library to __support your type__.+--+-- @+-- newtype UserName = Un { toText :: Text }+-- deriving stock (Show, Eq)+--+-- instance 'JwtRep' Text UserName where+-- rep = toText+-- unRep = Just . Un +-- @+-- +-- But there is an easier way. Just use /deriving/ clause+--+-- @+-- newtype UserName = Un { toText :: Text }+-- deriving stock (Show, Eq)+-- deriving newtype ('JwtRep' ByteString)+-- @+--+-- == JsonBuilder and lists+--+-- To encode values such as lists, a different strategy has to be used. +-- Because JWT values have to be in JSON format and there is no native support for more complex data structures (such as JSON arrays)+-- we have to do the conversion ourselves. For this we must know how to encode the value as a __JSON value__+--+-- This is the role of 'JsonBuilder' typeclass.+-- You must provide its instance if you want to be able to __encode lists of values of a custom type__.+--+-- If you already have a 'JwtRep' instance, the default implementation (use 'JsonBuilder' of the 'rep') should be fine+--+-- @+-- instance 'JsonBuilder' UserName+-- @+-- +-- or+--+-- @+-- newtype UserName = Un { toText :: Text }+-- deriving stock (Show, Eq)+-- deriving newtype ('JwtRep' ByteString, 'JsonBuilder')+-- @+--+-- = Decoding+--+-- The decoders are similarily divided into three groups:+--+-- * /Native/ - types: ByteString, Bool, Int, NumericDate and 'JsonByteString'.+-- Decoded in C+-- * /Derived/ - types for which a 'JwtRep' instance exists.+-- They are extracted via 'unRep' (transitively) from something we could decode+-- * /Specialized/ - Lists+--+-- == JwtRep typeclass+--+-- 'JwtRep' also knows how to go backwards - from the JWT representation to, maybe, a value. To complete the 'UUID' example+-- +-- @+-- instance 'JwtRep' ByteString UUID where+-- rep = 'UUID.toASCIIBytes'+-- unRep = 'UUID.fromASCIIBytes'+-- @+--+-- /Derived/ decoder will first try to parse a byteString from JSON, and then convert it via 'unRep' to a UUID.+-- Each of these steps can fail - the failure will manifest itself as "Libjwt.Exceptions.MissingClaim" or+-- @Nothing@ if all you want is @Maybe UUID@+--+-- And of course, 'JwtRep' of @UserName@ handles decoding the same way as described.+--+-- == JsonParser and lists+--+-- 'JsonParser' performs the opposite role of 'JsonBuilder' during decoding. It is used for extracting values+-- out of JSON arrays+--+-- You must provide its instance if you want to be able to __decode lists of values of a custom type__.+--+-- And again - the default implementation (@unRep <=< jsonParser@) should be fine+--+-- @+-- instance 'JsonParser' UserName+-- @+-- +-- or+--+-- @+-- newtype UserName = Un { toText :: Text }+-- deriving stock (Show, Eq)+-- deriving newtype ('JwtRep' ByteString, 'JsonBuilder', 'JsonParser')+-- @+--+-- = Integration with aeson+--+-- If you want to work with more complex objects as claims (e.g. lists of records) or+-- you just want to integrate this library with your existing code that uses /aeson/ - it's simple+-- +-- @+-- data Account = MkAccount { account_name :: Text, account_id :: UUID }+-- deriving stock (Show, Eq, Generic)+-- +-- instance FromJSON Account+-- instance ToJSON Account+-- +-- instance 'JwtRep' 'JsonByteString' Account where+-- rep = Json . encode+-- unRep = decode . toJson+-- +-- instance 'JsonBuilder' Account+-- instance 'JsonParser' Account+-- @+--+-- 'JsonByteString' is for cases where you already have your claims correctly represented as JSON,+-- so you can use /aeson/ (or any other method) to create 'JsonByteString'.+--+-- = Warning+--+-- Do not use @\NUL@ characters in strings you encode or decode with this library.+-- Safety is not guaranteed (ie, may crash your program) due to the way /libjwt/ works.+module Libjwt.Classes+ ( JwtRep(..)+ , JsonBuilder(..)+ , JsonParser(..)+ , JsonToken(..)+ )+where++import Libjwt.ASCII+import Libjwt.FFI.Jwt ( JsonToken(..) )+import Libjwt.Flag+import Libjwt.JsonByteString+import Libjwt.NumericDate++import Control.Monad ( guard+ , (<=<)+ )+import Control.Monad.Zip ( mzip )++import Data.ByteString ( ByteString )+import qualified Data.ByteString as Word8+import Data.ByteString.Builder ( Builder+ , char7+ , byteString+ , intDec+ , int64Dec+ , string7+ , charUtf8+ )+import Data.ByteString.Builder.Extra ( toLazyByteStringWith+ , safeStrategy+ )+import Data.ByteString.Builder.Prim ( (>*<)+ , condB+ , (>$<)+ , liftFixedToBounded+ )+import qualified Data.ByteString.Builder.Prim as E+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Lazy.Char8 as Lazy8++import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8+import qualified Data.ByteString.UTF8 as UTF8++import Data.Char ( ord+ , digitToInt+ , chr+ )+import Data.Coerce ( coerce )++import Data.Either.Extra ( eitherToMaybe )++import Data.List ( intersperse )+import Data.List.NonEmpty ( NonEmpty )+import qualified Data.List.NonEmpty as NEL+import Data.Maybe ( fromJust )++import Data.Text ( Text )+import qualified Data.Text.Encoding as Text+import Data.Text.Lazy ( toStrict )+import qualified Data.Text.Lazy.Encoding as LazyText++import Data.Time.Calendar ( Day )+import Data.Time.Clock+import Data.Time.Format.ISO8601+import Data.Time.LocalTime++import Data.UUID ( UUID )+import qualified Data.UUID as UUID++import Data.Word ( Word16+ , Word8+ )++-- | Conversion between @a@ and @b@ +--+-- If an instance of this typeclass exists for a type @b@, then JWT encoder and decoder can be derived for that type.+-- This derived encoder/decoder will use the encoder/decoder of @a@ and perform the convertions through this typeclass.+class JwtRep a b | b -> a where+ -- | Convert @b@ to @a@+ rep :: b -> a+ -- | Try to convert @a@ to @b@, returning @Nothing@ if unable+ unRep :: a -> Maybe b++instance JwtRep ByteString String where+ rep = UTF8.fromString+ unRep = Just . UTF8.toString++instance JwtRep ByteString ASCII where+ rep = Char8.pack . coerce+ unRep = coerce . Just . Char8.unpack++instance JwtRep ByteString UUID where+ rep = UUID.toASCIIBytes+ unRep = UUID.fromASCIIBytes++encodeAsIso8601 :: (ISO8601 t) => t -> ASCII+encodeAsIso8601 = ASCII . iso8601Show++decodeFromISO8601 :: (ISO8601 t) => ASCII -> Maybe t+decodeFromISO8601 = iso8601ParseM . getASCII++instance JwtRep ASCII UTCTime where+ rep = encodeAsIso8601+ unRep = decodeFromISO8601++instance JwtRep ASCII ZonedTime where+ rep = encodeAsIso8601+ unRep = decodeFromISO8601++instance JwtRep ASCII LocalTime where+ rep = encodeAsIso8601+ unRep = decodeFromISO8601++instance JwtRep ASCII Day where+ rep = encodeAsIso8601+ unRep = decodeFromISO8601++instance JwtRep ByteString Text where+ rep = Text.encodeUtf8+ unRep = eitherToMaybe . Text.decodeUtf8'++instance JwtRep [a] (NonEmpty a) where+ rep = NEL.toList+ unRep = NEL.nonEmpty++instance AFlag a => JwtRep ASCII (Flag a) where+ rep = getFlagValue+ unRep = setFlagValue++-- | Types that can be converted to a valid JSON representation+--+-- This typeclass will be used to encode a list of @t@ values (or a list of tuples whose element is of type @t@)+class JsonBuilder t where+ -- | Encode as JSON.+ -- + -- Must generate a valid JSON value: take care of quoting, escaping, UTF-8 encoding etc.+ jsonBuilder :: t -> Builder++ default jsonBuilder :: (JwtRep a t, JsonBuilder a) => t -> Builder+ jsonBuilder = jsonBuilder . rep++instance JsonBuilder ByteString where+ jsonBuilder = optimizedEscapeWords E.primMapByteStringBounded++instance JsonBuilder Bool where+ jsonBuilder True = "true"+ jsonBuilder False = "false"++instance JsonBuilder Int where+ jsonBuilder = intDec++instance JsonBuilder NumericDate where+ jsonBuilder = int64Dec . coerce++instance {-# OVERLAPPING #-} JsonBuilder String where+ jsonBuilder = optimizedEscapeString E.charUtf8++instance JsonBuilder ASCII where+ jsonBuilder = optimizedEscapeString (liftFixedToBounded E.char7) . getASCII++instance JsonBuilder Text where+ jsonBuilder = optimizedEscapeWords Text.encodeUtf8BuilderEscaped++instance JsonBuilder UUID where+ jsonBuilder = quoteString . byteString . UUID.toASCIIBytes++iso8601Builder :: (ISO8601 t) => t -> Builder+iso8601Builder = quoteString . string7 . iso8601Show++instance JsonBuilder UTCTime where+ jsonBuilder = iso8601Builder++instance JsonBuilder LocalTime where+ jsonBuilder = iso8601Builder++instance JsonBuilder ZonedTime where+ jsonBuilder = iso8601Builder++instance JsonBuilder Day where+ jsonBuilder = iso8601Builder++instance AFlag a => JsonBuilder (Flag a) where+ jsonBuilder = quoteString . string7 . getASCII . getFlagValue++instance JsonBuilder JsonByteString where+ jsonBuilder = toJsonBuilder++instance JsonBuilder a => JsonBuilder [a] where+ jsonBuilder = encodeArray++instance JsonBuilder a => JsonBuilder (Maybe a) where+ jsonBuilder Nothing = "null"+ jsonBuilder (Just a) = jsonBuilder a++instance (JsonBuilder a, JsonBuilder b) => JsonBuilder (a, b) where+ jsonBuilder (a, b) =+ arrayBrackets $ jsonBuilder a <> char7 ',' <> jsonBuilder b++encodeArray :: JsonBuilder a => [a] -> Builder+encodeArray =+ arrayBrackets . mconcat . intersperse (char7 ',') . map jsonBuilder++arrayBrackets :: Builder -> Builder+arrayBrackets bs = char7 '[' <> bs <> char7 ']'++quoteString :: Builder -> Builder+quoteString bs = char7 '"' <> bs <> char7 '"'++optimizedEscapeWords :: (E.BoundedPrim Word8 -> a -> Builder) -> a -> Builder+optimizedEscapeWords f = quoteString . f+ ( condB (== 92) (fixed2 ('\\', '\\'))+ $ condB (== 34) (fixed2 ('\\', '"'))+ $ condB (>= 32) (liftFixedToBounded E.word8)+ $ condB (== 13) (fixed2 ('\\', 'r'))+ $ condB (== 12) (fixed2 ('\\', 'f'))+ $ condB (== 10) (fixed2 ('\\', 'n'))+ $ condB (== 9) (fixed2 ('\\', 't'))+ $ condB (== 8) (fixed2 ('\\', 'b'))+ $ liftFixedToBounded+ $ fromIntegral+ >$< uEscape+ )++optimizedEscapeString :: E.BoundedPrim Char -> String -> Builder+optimizedEscapeString enc = quoteString . E.primMapListBounded escape+ where+ escape =+ condB (== '\\') (fixed2 ('\\', '\\'))+ $ condB (== '"') (fixed2 ('\\', '"'))+ $ condB (>= ' ') enc+ $ condB (== '\r') (fixed2 ('\\', 'r'))+ $ condB (== '\f') (fixed2 ('\\', 'f'))+ $ condB (== '\n') (fixed2 ('\\', 'n'))+ $ condB (== '\t') (fixed2 ('\\', 't'))+ $ condB (== '\b') (fixed2 ('\\', 'b'))+ $ liftFixedToBounded+ $ (fromIntegral . ord)+ >$< uEscape++-- | Types that can be converted from JSON representation+--+-- This typeclass will be used to decode a list of @a@ values (or a list of tuples whose element is of type @a@)+class JsonParser a where+ -- | Decode from JSON token.+ jsonParser :: JsonToken -> Maybe a++ default jsonParser :: (JwtRep t a, JsonParser t) => JsonToken -> Maybe a+ jsonParser = unRep <=< jsonParser++instance JsonParser ByteString where+ jsonParser (JsStr bs) = Just $ withUnescapedString Lazy.toStrict id bs+ jsonParser _ = Nothing++instance JsonParser Bool where+ jsonParser JsTrue = Just True+ jsonParser JsFalse = Just False+ jsonParser _ = Nothing++instance JsonParser Int where+ jsonParser (JsNum bs) = do+ (int, remainder) <- Char8.readInt bs+ guard $ Char8.null remainder+ return int+ jsonParser _ = Nothing++instance {-# OVERLAPPING #-} JsonParser String where+ jsonParser (JsStr bs) =+ Just $ withUnescapedString LazyUTF8.toString UTF8.toString bs+ jsonParser _ = Nothing++instance JsonParser ASCII where+ jsonParser (JsStr bs) =+ Just $ coerce $ withUnescapedString Lazy8.unpack Char8.unpack bs+ jsonParser _ = Nothing++instance JsonParser Text where+ jsonParser (JsStr bs) = eitherToMaybe $ withUnescapedString+ (fmap toStrict . LazyText.decodeUtf8')+ Text.decodeUtf8'+ bs+ jsonParser _ = Nothing++instance JsonParser NumericDate where+ jsonParser (JsNum bs) = do+ (int, remainder) <- Char8.readInteger bs+ guard $ Char8.null remainder+ return $ NumericDate $ fromInteger int+ jsonParser _ = Nothing++instance JsonParser UUID where+ jsonParser (JsStr bs) = UUID.fromASCIIBytes bs+ jsonParser _ = Nothing++iso8601Parser :: ISO8601 t => JsonToken -> Maybe t+iso8601Parser (JsStr bs) = iso8601ParseM $ Char8.unpack bs+iso8601Parser _ = Nothing++instance JsonParser UTCTime where+ jsonParser = iso8601Parser++instance JsonParser LocalTime where+ jsonParser = iso8601Parser++instance JsonParser ZonedTime where+ jsonParser = iso8601Parser++instance JsonParser Day where+ jsonParser = iso8601Parser++instance AFlag a => JsonParser (Flag a) where+ jsonParser (JsStr bs) = setFlagValue $ ASCII $ Char8.unpack bs+ jsonParser _ = Nothing++instance JsonParser JsonByteString where+ jsonParser (JsBlob bs) = Just $ jsonFromStrict bs+ jsonParser _ = Nothing++instance JsonParser a => JsonParser [a] where+ jsonParser (JsArray as) = traverse jsonParser as+ jsonParser _ = Nothing++instance JsonParser a => JsonParser (Maybe a) where+ jsonParser JsNull = Just Nothing+ jsonParser a' = Just <$> jsonParser a'++instance (JsonParser a, JsonParser b) => JsonParser (a, b) where+ jsonParser (JsArray [a', b']) = mzip (jsonParser a') (jsonParser b')+ jsonParser _ = Nothing++withUnescapedString+ :: (Lazy.ByteString -> a) -> (ByteString -> a) -> ByteString -> a+withUnescapedString lazy strict bs = case Word8.break (== 92) bs of+ (x, y)+ | Word8.null y -> strict x+ | otherwise -> lazy+ $ toLazyByteStringWith allocationStrategy mempty (byteString x <> go0 y)+ where+ go0 ws = case fromJust $ Word8.uncons rest of+ (h, tl)+ | h == 117+ -> let (hex, tl') = Word8.splitAt 4 tl+ in charUtf8 (chr $ hexValue hex) <> builder tl'+ | h == 116+ -> char7 '\t' <> builder tl+ | h == 114+ -> char7 '\r' <> builder tl+ | h == 110+ -> char7 '\n' <> builder tl+ | h == 102+ -> char7 '\f' <> builder tl+ | h == 98+ -> char7 '\b' <> builder tl+ | h == 92+ -> char7 '\\' <> builder tl+ | otherwise+ -> go1 rest+ where+ rest = Word8.tail ws+ builder b = case Word8.uncons b of+ Nothing -> mempty+ Just (h, _) | h == 92 -> go0 b+ | otherwise -> go1 b++ go1 ws = case Word8.break (== 92) ws of+ (x, y) | Word8.null y -> byteString x+ | otherwise -> byteString x <> go0 y++ allocationStrategy =+ let initialLength = Word8.length bs+ wanted = min 32 $ (initialLength + 7) `div` 8 * 8+ in safeStrategy wanted wanted++ hexValue = Char8.foldl' (\val c -> val * 16 + digitToInt c) 0++fixed2 :: (Char, Char) -> E.BoundedPrim b+fixed2 repl = liftFixedToBounded $ const repl >$< E.char7 >*< E.char7+{-# INLINE fixed2 #-}++uEscape :: E.FixedPrim Word16+uEscape = (('\\', 'u'), ) >$< (E.char7 >*< E.char7) >*< E.word16HexFixed+{-# INLINE uEscape #-}+
+ src/Libjwt/Decoding.hs view
@@ -0,0 +1,148 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | JWT decoding definition+-- +-- __This module can be considered internal to the library__+-- Users should never need to implement the `Decode` typeclass or use any of the exported functions or types directly.+-- You'll only need to know of `Decode` typeclass if you want to write a function polymorphic in the type of payloads. +--+-- If you want to extend the types supported by the library, see "Libjwt.Classes"+module Libjwt.Decoding+ ( DecodeResult(..)+ , hoistResult+ , ClaimDecoder(..)+ , Decode(..)+ , getOrEmpty+ , decodeClaimOrThrow+ , decodeClaimProxied+ , Decodable+ , JwtIO+ )+where++import Libjwt.Classes+import Libjwt.Exceptions ( MissingClaim(..) )+import Libjwt.FFI.Jwt+import Libjwt.JsonByteString+import Libjwt.NumericDate++import Control.Applicative ( Alternative )+import Control.Monad ( (<=<) )++import Control.Monad.Catch ( throwM )++import Control.Monad.Trans.Maybe++import Data.ByteString ( ByteString )++import Data.Coerce+import Data.Kind ( Constraint )+import Data.Maybe ( fromMaybe )+import Data.Proxy++newtype DecodeResult t = Result { getOptional :: JwtIO (Maybe t) }+ deriving (Functor, Applicative, Monad, Alternative) via (MaybeT JwtIO)++-- | Lift pure value+hoistResult :: Maybe a -> DecodeResult a+hoistResult = Result . pure++-- | Action that returns 'mempty' if decoding has failed+getOrEmpty :: (Monoid a) => DecodeResult a -> JwtIO a+getOrEmpty (Result x) = fromMaybe mempty <$> x++-- | 'decodeClaim' through proxy+decodeClaimProxied+ :: (ClaimDecoder t) => String -> proxy t -> JwtT -> DecodeResult t+decodeClaimProxied name _ = decodeClaim name++-- | Action that throws 'MissingClaim' if decoding has failed+decodeClaimOrThrow :: (ClaimDecoder t) => String -> proxy t -> JwtT -> JwtIO t+decodeClaimOrThrow name p =+ maybe (throwM $ Missing name) return+ <=< getOptional+ . decodeClaimProxied name p++data DecoderType = Native | Derived++type family DecoderDef a :: DecoderType where+ DecoderDef ByteString = 'Native+ DecoderDef Bool = 'Native+ DecoderDef Int = 'Native+ DecoderDef NumericDate = 'Native+ DecoderDef JsonByteString = 'Native+ DecoderDef String = 'Derived+ DecoderDef [a] = 'Native+ DecoderDef _ = 'Derived++-- | Low-level definition of claims decoding.+class ClaimDecoder t where+ -- | Given a pointer to /jwt_t/, try to decode the value of type @t@+ decodeClaim :: String -> JwtT -> DecodeResult t++instance (DecoderDef a ~ ty, ClaimDecoder' ty a) => ClaimDecoder a where+ decodeClaim = decodeClaim' (Proxy :: Proxy ty)++class ClaimDecoder' (ty :: DecoderType) t where+ decodeClaim' :: proxy ty -> String -> JwtT -> DecodeResult t++instance ClaimDecoder' 'Native ByteString where+ decodeClaim' _ name = Result . getGrant name+ {-# INLINE decodeClaim' #-}++instance ClaimDecoder' 'Native Bool where+ decodeClaim' _ name = Result . getGrantBool name+ {-# INLINE decodeClaim' #-}++instance ClaimDecoder' 'Native Int where+ decodeClaim' _ name = Result . getGrantInt name+ {-# INLINE decodeClaim' #-}++instance ClaimDecoder' 'Native NumericDate where+ decodeClaim' _ name = coerce . getGrantInt64 name+ {-# INLINE decodeClaim' #-}++instance ClaimDecoder' 'Native JsonByteString where+ decodeClaim' _ name = fmap jsonFromStrict . Result . getGrantAsJson name+ {-# INLINE decodeClaim' #-}++fromJsonNative+ :: (JsonByteString -> JwtIO (Maybe a)) -> String -> JwtT -> DecodeResult a+fromJsonNative f name =+ (Result . f) <=< decodeClaim' (Proxy :: Proxy 'Native) name+{-# INLINE fromJsonNative #-}++instance JsonParser a => ClaimDecoder' 'Native [a] where+ decodeClaim' _ =+ fromJsonNative+ $ fmap (sequence =<<)+ . unsafeMapTokenizedJsonArray jsonParser+ . toJsonStrict+ {-# INLINE decodeClaim' #-}++instance (JwtRep b a, DecoderDef b ~ ty, ClaimDecoder' ty b) => ClaimDecoder' 'Derived a where+ decodeClaim' _ name =+ (hoistResult . unRep) <=< decodeClaim' (Proxy :: Proxy ty) name++type family Decodable t :: Constraint where+ Decodable t = ClaimDecoder' (DecoderDef t) t++-- | Definition of claims decoding.+-- +-- The only use for the user is probably to write a function that is polymorphic in the payload type+class Decode c where+ -- | Construct an action that decodes the value of type @c@, given a pointer to /jwt_t/. The action may fail.+ decode :: JwtT -> JwtIO c+
+ src/Libjwt/Encoding.hs view
@@ -0,0 +1,123 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | JWT encoding definition+-- +-- __This module can be considered internal to the library__+-- Users should never need to implement the `Encode` typeclass or use any of the exported functions or types directly.+-- You'll only need to know of `Encode` typeclass if you want to write a function polymorphic in the type of payloads. +--+-- If you want to extend the types supported by the library, see "Libjwt.Classes"+module Libjwt.Encoding+ ( EncodeResult+ , Encode(..)+ , ClaimEncoder(..)+ , nullEncode+ )+where++import Libjwt.Classes+import Libjwt.FFI.Jwt+import Libjwt.JsonByteString+import Libjwt.NumericDate++import Data.ByteString ( ByteString )+import Data.ByteString.Builder ( Builder+ , char7+ , string7+ , lazyByteString+ )+import Data.ByteString.Builder.Extra ( toLazyByteStringWith+ , safeStrategy+ )+import Data.ByteString.Lazy ( toStrict )++import Data.Coerce ( coerce )+import Data.Proxy ( Proxy(..) )++type EncodeResult = JwtIO ()++-- | Do not perform any action. It is used to encode things like empty lists or /Nothing/+nullEncode :: b -> EncodeResult+nullEncode = const $ return ()++data EncoderType = Native | Spec | Derived++type family EncoderDef a :: EncoderType where+ EncoderDef (Maybe a) = 'Spec+ EncoderDef ByteString = 'Native+ EncoderDef Bool = 'Native+ EncoderDef Int = 'Native+ EncoderDef NumericDate = 'Native+ EncoderDef JsonByteString = 'Native+ EncoderDef String = 'Derived+ EncoderDef [a] = 'Spec+ EncoderDef _ = 'Derived++-- | Low-level definition of JWT claims encoding.+class ClaimEncoder t where+ -- | Given a pointer to /jwt_t/, mutate the structure it points to to encode the value as a named claim+ -- It relies on the functions exported from "Libjwt.FFI.Jwt" to perform an /impure/ effect of /encoding/+ encodeClaim :: String -> t -> JwtT -> EncodeResult++instance (EncoderDef a ~ ty, ClaimEncoder' ty a) => ClaimEncoder a where+ encodeClaim = encodeClaim' (Proxy :: Proxy ty)++class ClaimEncoder' (ty :: EncoderType) t where+ encodeClaim' :: proxy ty -> String -> t -> JwtT -> EncodeResult++instance ClaimEncoder a => ClaimEncoder' 'Spec (Maybe a) where+ encodeClaim' _ name (Just val) = encodeClaim name val+ encodeClaim' _ _ Nothing = nullEncode++instance JsonBuilder a => ClaimEncoder' 'Spec [a] where+ encodeClaim' _ _ [] = nullEncode+ encodeClaim' _ name as = fromJson name $ jsonBuilder as++instance ClaimEncoder' 'Native ByteString where+ encodeClaim' _ = addGrant++instance ClaimEncoder' 'Native Bool where+ encodeClaim' _ = addGrantBool++instance ClaimEncoder' 'Native Int where+ encodeClaim' _ = addGrantInt++instance ClaimEncoder' 'Native NumericDate where+ encodeClaim' _ name = addGrantInt64 name . coerce+ {-# INLINE encodeClaim' #-}++fromJson :: String -> Builder -> JwtT -> JwtIO ()+fromJson name =+ addGrantsFromJson+ . toStrict+ . toLazyByteStringWith (safeStrategy 64 512) mempty+ . encodeAsObject1+ where+ encodeAsObject1 = objectBrackets . ((fieldName <> char7 ':') <>)+ where+ objectBrackets bs = char7 '{' <> bs <> char7 '}'+ fieldName = char7 '"' <> string7 name <> char7 '"'++instance ClaimEncoder' 'Native JsonByteString where+ encodeClaim' _ name = fromJson name . lazyByteString . toJson++instance (JwtRep b a, EncoderDef b ~ ty, ClaimEncoder' ty b) => ClaimEncoder' 'Derived a where+ encodeClaim' _ name = encodeClaim' (Proxy :: Proxy ty) name . rep++-- | Definition of claims encoding.+-- +-- The only use for the user is probably to write a function that is polymorphic in the payload type.+class Encode c where+ -- | Perform the encoding as /impure/ action+ encode :: c -> JwtT -> EncodeResult
+ src/Libjwt/Exceptions.hs view
@@ -0,0 +1,85 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}++-- | Exceptions that may be thrown while decoding a token+module Libjwt.Exceptions+ ( SomeDecodeException+ , DecodeException(..)+ , MissingClaim(..)+ , AlgorithmMismatch(..)+ )+where++import Control.Exception ( Exception(..) )+import Data.Typeable ( cast )++-- | The root of the decoding exceptions hierarchy.+-- You can use it to catch all possible exceptions that may occur while decoding a token. +data SomeDecodeException = forall e . Exception e => SomeDecodeException e++instance Show SomeDecodeException where+ show (SomeDecodeException e) = show e++instance Exception SomeDecodeException where+ displayException (SomeDecodeException e) = displayException e++-- | Thrown when the token does not represent a decodable JWT object i.e.+-- +-- * invalid UTF-8+-- * malformed JSON+-- * its signature cannot be verified+--+-- Basically, this token cannot be accepted for further processing because either we cannot determine its authenticity or it is garbage.+newtype DecodeException = DecodeException String+ deriving stock (Show)++instance Exception DecodeException where+ toException = toException . SomeDecodeException++ fromException x = do+ SomeDecodeException a <- fromException x+ cast a++ displayException (DecodeException token) =+ "The token \n----\n"+ ++ token+ ++ "\n----\ndoes not represent a decodable JWT object.\+ \ The possible reasons include:\+ \ its signature cannot be verified;\+ \ malformed JSON;\+ \ it uses an unsupported encoding algorithm.\+ \ We cannot accept this token for further processing because either we cannot determine its authenticity or it is garbage."++-- | Raised when a required claim is not present in the JWT object+newtype MissingClaim = Missing String+ deriving stock (Show)++instance Exception MissingClaim where+ toException = toException . SomeDecodeException++ fromException x = do+ SomeDecodeException a <- fromException x+ cast a++ displayException (Missing name) =+ "required claim '" ++ name ++ "' is missing"++-- | Raised when the JWT object uses a different algorithm in the header then the one we are trying to decode it with+data AlgorithmMismatch = AlgorithmMismatch+ deriving stock (Show)++instance Exception AlgorithmMismatch where+ toException = toException . SomeDecodeException++ fromException x = do+ SomeDecodeException a <- fromException x+ cast a++ displayException _ =+ "The token was signed using a different algorithm than expected"
+ src/Libjwt/FFI/Jsmn.hsc view
@@ -0,0 +1,46 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Libjwt.FFI.Jsmn where++import Foreign+import Foreign.C.Types++data JsmnTokT = Token { jsmnType :: JsmnTypeT, start :: CInt, end :: CInt, size :: CInt, parent :: CInt }++peekType :: Ptr JsmnTokT -> IO JsmnTypeT+peekType ptr = peekByteOff ptr (#offset jsmntok_t, type)++peekParent :: Ptr JsmnTokT -> IO CInt+peekParent ptr = peekByteOff ptr (#offset jsmntok_t, parent)++instance Storable JsmnTokT where+ sizeOf _ = (#size jsmntok_t)+ alignment _ = (#alignment jsmntok_t)++ peek ptr = Token + <$> (#peek jsmntok_t, type) ptr + <*> (#peek jsmntok_t, start) ptr + <*> (#peek jsmntok_t, end) ptr+ <*> (#peek jsmntok_t, size) ptr+ <*> (#peek jsmntok_t, parent) ptr++ poke ptr (Token (JsmnType t) st e sz p) = do+ (#poke jsmntok_t, type) ptr t+ (#poke jsmntok_t, start) ptr st+ (#poke jsmntok_t, end) ptr e+ (#poke jsmntok_t, size) ptr sz+ (#poke jsmntok_t, parent) ptr p++newtype JsmnTypeT = JsmnType CInt+ deriving stock Eq+ deriving newtype Storable++#include "jsmn.h"++#{enum JsmnTypeT, JsmnType, JSMN_UNDEFINED, JSMN_OBJECT, JSMN_ARRAY, JSMN_STRING, JSMN_PRIMITIVE }
+ src/Libjwt/FFI/Jwt.hs view
@@ -0,0 +1,439 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}++-- | Interface to C libraries +module Libjwt.FFI.Jwt+ ( JwtIO+ , unsafePerformJwtIO+ , JwtT+ , mkJwtT+ , jwtDecode+ , jwtEncode+ , addGrant+ , addGrantBool+ , addGrantInt+ , addGrantInt64+ , addGrantsFromJson+ , jwtSetAlg+ , addHeader+ , getGrant+ , getGrantBool+ , getGrantInt+ , getGrantInt64+ , getGrantAsJson+ , jwtGetAlg+ , getHeader+ , unsafeAddGrant+ , unsafeAddGrantBool+ , unsafeAddGrantInt+ , unsafeAddGrantInt64+ , unsafeAddHeader+ , unsafeGetGrant+ , unsafeGetGrantBool+ , unsafeGetGrantInt+ , unsafeGetGrantInt64+ , unsafeGetGrantAsJson+ , unsafeGetHeader+ , JsonToken(..)+ , unsafeMapTokenizedJsonArray+ )+where++import Libjwt.FFI.Libjwt+import Libjwt.FFI.Jsmn++import Control.Exception ( throwIO )+import Control.Monad ( void+ , (<=<)+ )++import Control.Monad.Catch ( MonadCatch+ , MonadThrow+ )++import Control.Monad.Extra ( whenMaybe+ , loopM+ )++import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Class ( lift )++import Data.ByteString ( ByteString+ , useAsCString+ , packCString+ , packCStringLen+ )+import Data.ByteString.Unsafe ( unsafePackMallocCString+ , unsafeUseAsCStringLen+ )++import Foreign hiding ( void )+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error++import GHC.Base ( unpackCString# )+import GHC.Exts++import System.IO.Unsafe ( unsafePerformIO )++-- | IO restricted to calling /libjwt/ and /jsmn/+newtype JwtIO a = JIO (IO a)+ deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch)++-- | Wrapped pointer to /jwt_t/ with managed lifetime+newtype JwtT = JwtT (ForeignPtr JwtT)++unsafePerformJwtIO :: JwtIO a -> a+unsafePerformJwtIO (JIO io) = unsafePerformIO io++mkJwtT :: JwtIO JwtT+mkJwtT = JIO $ mkJwtT_ "jwt_new" c_jwt_new++jwtDecode :: Maybe ByteString -> ByteString -> JwtIO JwtT+jwtDecode maybeKey token = JIO+ $ maybe ($ (nullPtr, 0)) unsafeUseAsCStringLen maybeKey doDecode+ where+ doDecode (p_key, key_len) = useAsCString token $ \p_token ->+ mkJwtT_ "jwt_decode"+ $ \ret -> c_jwt_decode ret p_token p_key $ fromIntegral key_len++mkJwtT_ :: String -> (Ptr PJwtT -> IO CInt) -> IO JwtT+mkJwtT_ loc ctr = alloca $ \ptr -> do+ res <- ctr ptr+ if res == 0 then wrapJwtPtr =<< peek ptr else throwLibjwt loc $ Errno res++type PJwtT = Ptr JwtT++{-# RULES+"addGrant/unsafeAddGrant" forall s . addGrant (unpackCString# s) = unsafeAddGrant s+"addGrantBool/unsafeAddGrantBool" forall s . addGrantBool (unpackCString# s) = unsafeAddGrantBool s+"addGrantInt64/unsafeAddGrantInt64" forall s . addGrantInt64 (unpackCString# s) = unsafeAddGrantInt64 s+"addGrantInt/unsafeAddGrantInt" forall s . addGrantInt (unpackCString# s) = unsafeAddGrantInt s+"addHeader/unsafeAddHeader" forall s . addHeader (unpackCString# s) = unsafeAddHeader s #-}++{-# INLINE [0] addGrant #-}+{-# INLINE [0] addGrantBool #-}+{-# INLINE [0] addGrantInt64 #-}+{-# INLINE [0] addGrantInt #-}+{-# INLINE [0] addHeader #-}++addGrant :: String -> ByteString -> JwtT -> JwtIO ()+addGrant grant val jwt = JIO $ useAsCString val $ \p_val ->+ _addGrant "jwt_add_grant" c_jwt_add_grant grant p_val jwt++unsafeAddGrant :: Addr# -> ByteString -> JwtT -> JwtIO ()+unsafeAddGrant p_grant val jwt = JIO $ useAsCString val $ \p_val ->+ _unsafeAddGrant "jwt_add_grant" c_jwt_add_grant p_grant p_val jwt++addGrantBool :: String -> Bool -> JwtT -> JwtIO ()+addGrantBool grant =+ coerce . _addGrant "jwt_add_grant_bool" c_jwt_add_grant_bool grant . fromBool++unsafeAddGrantBool :: Addr# -> Bool -> JwtT -> JwtIO ()+unsafeAddGrantBool p_grant =+ coerce+ . _unsafeAddGrant "jwt_add_grant_bool" c_jwt_add_grant_bool p_grant+ . fromBool++addGrantInt64 :: String -> Int64 -> JwtT -> JwtIO ()+addGrantInt64 grant =+ coerce . _addGrant "jwt_add_grant_int" c_jwt_add_grant_int grant . coerce++unsafeAddGrantInt64 :: Addr# -> Int64 -> JwtT -> JwtIO ()+unsafeAddGrantInt64 p_grant =+ coerce+ . _unsafeAddGrant "jwt_add_grant_int" c_jwt_add_grant_int p_grant+ . coerce++addGrantInt :: String -> Int -> JwtT -> JwtIO ()+addGrantInt grant =+ coerce+ . _addGrant "jwt_add_grant_int" c_jwt_add_grant_int grant+ . fromIntegral++unsafeAddGrantInt :: Addr# -> Int -> JwtT -> JwtIO ()+unsafeAddGrantInt p_grant =+ coerce+ . _unsafeAddGrant "jwt_add_grant_int" c_jwt_add_grant_int p_grant+ . fromIntegral++_addGrant+ :: String+ -> (PJwtT -> CString -> p -> IO CInt)+ -> String+ -> p+ -> JwtT+ -> IO ()+_addGrant loc f grant val (JwtT pjwt_t) = withForeignPtr pjwt_t $ \jwt ->+ withCAString grant $ \p_grant -> throwIfNonZero_ loc $ f jwt p_grant val++_unsafeAddGrant+ :: String -> (PJwtT -> CString -> p -> IO CInt) -> Addr# -> p -> JwtT -> IO ()+_unsafeAddGrant loc f p_grant val (JwtT pjwt_t) =+ withForeignPtr pjwt_t $ \jwt -> throwIfNonZero_ loc $ f jwt (Ptr p_grant) val++addGrantsFromJson :: ByteString -> JwtT -> JwtIO ()+addGrantsFromJson json (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ useAsCString json+ $ throwIfNonZero_ "jwt_add_grants_json"+ . c_jwt_add_grants_json jwt++jwtSetAlg :: JwtAlgT -> ByteString -> JwtT -> JwtIO ()+jwtSetAlg alg key (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ if alg == jwtAlgNone+ then void $ c_jwt_set_alg jwt jwtAlgNone nullPtr 0+ else unsafeUseAsCStringLen key $ \(p_key, keylen) ->+ throwIfNonZero_ "jwt_set_alg" $ c_jwt_set_alg jwt alg p_key $ fromIntegral+ keylen++addHeader :: String -> ByteString -> JwtT -> JwtIO ()+addHeader h val (JwtT pjwt_t) =+ JIO $ useAsCString val $ \p_val -> withForeignPtr pjwt_t $ \jwt ->+ withCAString h $ \ph ->+ throwIfNonZero_ "jwt_add_header" $ c_jwt_add_header jwt ph p_val++unsafeAddHeader :: Addr# -> ByteString -> JwtT -> JwtIO ()+unsafeAddHeader p_header val (JwtT pjwt_t) =+ JIO $ useAsCString val $ \p_val -> withForeignPtr pjwt_t $ \jwt ->+ throwIfNonZero_ "jwt_add_header" $ c_jwt_add_header jwt (Ptr p_header) p_val++jwtEncode :: JwtT -> JwtIO ByteString+jwtEncode (JwtT pjwt_t) =+ JIO+ $ withForeignPtr pjwt_t+ $ unsafePackMallocCString+ <=< throwErrnoIfNull "jwt_encode_str"+ . c_jwt_encode_str++{-# RULES+"getGrant/unsafeGetGrant" forall s . getGrant (unpackCString# s) = unsafeGetGrant s+"getGrantBool/unsafeGetGrantBool" forall s . getGrantBool (unpackCString# s) = unsafeGetGrantBool s+"getGrantInt64/unsafeGetGrantInt64" forall s . getGrantInt64 (unpackCString# s) = unsafeGetGrantInt64 s+"getGrantInt/unsafeGetGrantInt" forall s . getGrantInt (unpackCString# s) = unsafeGetGrantInt s+"getGrantAsJson/unsafeGetGrantAsJson" forall s . getGrantAsJson (unpackCString# s) = unsafeGetGrantAsJson s+"getHeader/unsafeGetHeader" forall s . getHeader (unpackCString# s) = unsafeGetHeader s #-}++{-# INLINE [0] getGrant #-}+{-# INLINE [0] getGrantBool #-}+{-# INLINE [0] getGrantInt64 #-}+{-# INLINE [0] getGrantInt #-}+{-# INLINE [0] getGrantAsJson #-}+{-# INLINE [0] getHeader #-}++getGrant :: String -> JwtT -> JwtIO (Maybe ByteString)+getGrant grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString grant $ whenMaybeNotNull packCString . c_jwt_get_grant jwt++unsafeGetGrant :: Addr# -> JwtT -> JwtIO (Maybe ByteString)+unsafeGetGrant p_grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ whenMaybeNotNull packCString $ c_jwt_get_grant jwt $ Ptr p_grant++getGrantBool :: String -> JwtT -> JwtIO (Maybe Bool)+getGrantBool grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString grant+ $ throwErrnoOrNoEnt "jwt_get_grant_bool"+ . fmap toBool+ . c_jwt_get_grant_bool jwt++unsafeGetGrantBool :: Addr# -> JwtT -> JwtIO (Maybe Bool)+unsafeGetGrantBool p_grant (JwtT pjwt_t) =+ JIO $ withForeignPtr pjwt_t $ \jwt ->+ throwErrnoOrNoEnt "jwt_get_grant_bool"+ . fmap toBool+ . c_jwt_get_grant_bool jwt+ $ Ptr p_grant++getGrantInt64 :: String -> JwtT -> JwtIO (Maybe Int64)+getGrantInt64 grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString grant+ $ coerce+ . throwErrnoOrNoEnt "jwt_get_grant_int"+ . c_jwt_get_grant_int jwt++unsafeGetGrantInt64 :: Addr# -> JwtT -> JwtIO (Maybe Int64)+unsafeGetGrantInt64 p_grant (JwtT pjwt_t) =+ JIO $ withForeignPtr pjwt_t $ \jwt ->+ coerce+ . throwErrnoOrNoEnt "jwt_get_grant_int"+ . c_jwt_get_grant_int jwt+ $ Ptr p_grant+++getGrantInt :: String -> JwtT -> JwtIO (Maybe Int)+getGrantInt grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString grant+ $ throwErrnoOrNoEnt "jwt_get_grant_int"+ . fmap (fromIntegral :: CLong -> Int)+ . c_jwt_get_grant_int jwt++unsafeGetGrantInt :: Addr# -> JwtT -> JwtIO (Maybe Int)+unsafeGetGrantInt p_grant (JwtT pjwt_t) =+ JIO $ withForeignPtr pjwt_t $ \jwt ->+ throwErrnoOrNoEnt "jwt_get_grant_int"+ . fmap (fromIntegral :: CLong -> Int)+ . c_jwt_get_grant_int jwt+ $ Ptr p_grant++getGrantAsJson :: String -> JwtT -> JwtIO (Maybe ByteString)+getGrantAsJson grant (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString grant+ $ whenMaybeNotNull unsafePackMallocCString+ . c_jwt_get_grants_json jwt++unsafeGetGrantAsJson :: Addr# -> JwtT -> JwtIO (Maybe ByteString)+unsafeGetGrantAsJson p_grant (JwtT pjwt_t) =+ JIO $ withForeignPtr pjwt_t $ \jwt -> do+ val <- c_jwt_get_grants_json jwt $ Ptr p_grant+ whenMaybe (val /= nullPtr) $ unsafePackMallocCString val++jwtGetAlg :: JwtT -> JwtIO JwtAlgT+jwtGetAlg (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t c_jwt_get_alg++getHeader :: String -> JwtT -> JwtIO (Maybe ByteString)+getHeader h (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ withCAString h $ whenMaybeNotNull packCString . c_jwt_get_header jwt++unsafeGetHeader :: Addr# -> JwtT -> JwtIO (Maybe ByteString)+unsafeGetHeader p_header (JwtT pjwt_t) = JIO $ withForeignPtr pjwt_t $ \jwt ->+ whenMaybeNotNull packCString $ c_jwt_get_header jwt $ Ptr p_header++foreign import ccall unsafe "jwt.h jwt_new" c_jwt_new :: Ptr PJwtT -> IO CInt+foreign import ccall unsafe "jwt.h &jwt_free" p_jwt_free :: FunPtr (PJwtT -> IO ())+foreign import ccall unsafe "jwt.h jwt_add_grant" c_jwt_add_grant :: PJwtT -> CString -> CString -> IO CInt+foreign import ccall unsafe "jwt.h jwt_add_grant_bool" c_jwt_add_grant_bool :: PJwtT -> CString -> CInt -> IO CInt+foreign import ccall unsafe "jwt.h jwt_add_grant_int" c_jwt_add_grant_int :: PJwtT -> CString -> CLong -> IO CInt+foreign import ccall unsafe "jwt.h jwt_add_grants_json" c_jwt_add_grants_json :: PJwtT -> CString -> IO CInt+foreign import ccall unsafe "jwt.h jwt_get_grant" c_jwt_get_grant :: PJwtT -> CString -> IO CString+foreign import ccall unsafe "jwt.h jwt_get_grant_bool" c_jwt_get_grant_bool :: PJwtT -> CString -> IO CInt+foreign import ccall unsafe "jwt.h jwt_get_grant_int" c_jwt_get_grant_int :: PJwtT -> CString -> IO CLong+foreign import ccall unsafe "jwt.h jwt_get_grants_json" c_jwt_get_grants_json :: PJwtT -> CString -> IO CString+foreign import ccall unsafe "jwt.h jwt_set_alg" c_jwt_set_alg :: PJwtT -> JwtAlgT -> CString -> CInt -> IO CInt+foreign import ccall unsafe "jwt.h jwt_add_header" c_jwt_add_header :: PJwtT -> CString -> CString -> IO CInt+foreign import ccall unsafe "jwt.h jwt_encode_str" c_jwt_encode_str :: PJwtT -> IO CString+foreign import ccall unsafe "jwt.h jwt_get_alg" c_jwt_get_alg :: PJwtT -> IO JwtAlgT+foreign import ccall unsafe "jwt.h jwt_get_header" c_jwt_get_header :: PJwtT -> CString -> IO CString+foreign import ccall unsafe "jwt.h jwt_decode" c_jwt_decode :: Ptr PJwtT -> CString -> CString -> CInt -> IO CInt++type PJsmnTokT = Ptr JsmnTokT++-- | Low-level representation of JSON tokenization. Tokens are an exact representation of the underlying JSON, ie no conversions or unescaping has been performed.+--+-- The only exception is @JsStr@ which is already unquoted +-- (@JsStr@ value is the string between the first and last quotation marks of the corresponding JSON string).+--+-- JSON objects are not parsed at all, but presented as one byte string (@JsBlob@).+data JsonToken = JsStr ByteString+ | JsNum ByteString+ | JsTrue+ | JsFalse+ | JsNull+ | JsArray [JsonToken]+ | JsBlob ByteString++foldrJson :: (JsonToken -> b -> b) -> b -> CString -> PJsmnTokT -> Int -> IO b+foldrJson f z p_js ptokens count = evalStateT (go f z count) 0+ where+ peekToken = get >>= lift . peekElemOff ptokens+ offsetPlus1 = withStateT (+ 1)++ go :: (JsonToken -> a -> a) -> a -> Int -> StateT Int IO a+ go k a n+ | n == 0 = return a+ | otherwise = do+ tok <- peekToken+ case jsmnType tok of+ ttok+ | ttok == jsmnString+ -> k . JsStr <$> lift (pack tok) <*> offsetPlus1 (go k a (n - 1))+ | ttok == jsmnPrimitive+ -> k <$> lift (mkPrimToken tok) <*> offsetPlus1 (go k a (n - 1))+ | ttok == jsmnArray+ -> let len = fromIntegral $ size tok+ in k . JsArray <$> offsetPlus1 (go (:) [] len) <*> go k a (n - 1)+ | otherwise+ -> let supertok = parent tok+ in do+ j <- get >>= lift . nextSibling supertok . (+ 1)+ put j+ k . JsBlob <$> lift (pack tok) <*> go k a (n - 1)++ mkPrimToken tok = do+ c <- peekByteOff p_js $ fromIntegral $ start tok+ case (c :: CChar) of+ 116 -> return JsTrue+ 110 -> return JsNull+ 102 -> return JsFalse+ _ -> JsNum <$> pack tok++ pack tok =+ let s = start tok+ e = end tok+ n = e - s+ in packCStringLen (p_js `plusPtr` fromIntegral s, fromIntegral n)++ nextSibling supertok = loopM+ (\j -> do+ let temp = advancePtr ptokens j+ t <- peekType temp+ p <- peekParent temp+ return $ if t == jsmnUndefined || p == supertok+ then Right j+ else Left (j + 1)+ )++unsafeUseTokenizedJsonArray+ :: (CString -> Ptr JsmnTokT -> Int -> IO a) -> ByteString -> IO (Maybe a)+unsafeUseTokenizedJsonArray f js =+ unsafeUseAsCStringLen js $ \(p_js, jslen) -> alloca $ \out -> do+ r <- c_tokenize_json p_js (fromIntegral jslen) out+ if r < 0+ then throwLibjwt "tokenize_json" (Errno $ negate r)+ else do+ ptokens <- peek out+ tok0 <- peek ptokens+ res <- whenMaybe (jsmnType tok0 == jsmnArray)+ $ f p_js (advancePtr ptokens 1) (fromIntegral $ size tok0)+ free ptokens+ return res++unsafeMapTokenizedJsonArray+ :: (JsonToken -> b) -> ByteString -> JwtIO (Maybe [b])+unsafeMapTokenizedJsonArray f =+ JIO . unsafeUseTokenizedJsonArray (foldrJson ((:) . f) [])++foreign import ccall unsafe "tokenize_json" c_tokenize_json :: CString -> CSize -> Ptr PJsmnTokT -> IO CInt++wrapJwtPtr :: PJwtT -> IO JwtT+wrapJwtPtr = coerce . newForeignPtr p_jwt_free++throwIfNonZero_ :: String -> IO CInt -> IO ()+throwIfNonZero_ loc f = do+ res <- f+ if res == 0 then return () else throwLibjwt loc $ Errno res++whenMaybeNotNull :: (Ptr a -> IO b) -> IO (Ptr a) -> IO (Maybe b)+whenMaybeNotNull f io = do+ res <- io+ whenMaybe (res /= nullPtr) $ f res++throwLibjwt :: String -> Errno -> IO a+throwLibjwt loc err = throwIO $ errnoToIOError loc err Nothing Nothing++throwErrnoOrNoEnt :: String -> IO a -> IO (Maybe a)+throwErrnoOrNoEnt loc f = do+ res <- f+ err <- getErrno+ if err == eOK+ then return $ Just res+ else if err == eNOENT || err == eINVAL+ then return Nothing+ else throwLibjwt loc err
+ src/Libjwt/FFI/Libjwt.hsc view
@@ -0,0 +1,17 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE DerivingStrategies #-}++module Libjwt.FFI.Libjwt where++import Foreign.C.Types++newtype JwtAlgT = JwtAlg CInt+ deriving stock Eq++#include <jwt.h>++#{enum JwtAlgT, JwtAlg, JWT_ALG_NONE, JWT_ALG_HS256, JWT_ALG_HS384, JWT_ALG_HS512, JWT_ALG_RS256, JWT_ALG_RS384, JWT_ALG_RS512, JWT_ALG_ES256, JWT_ALG_ES384, JWT_ALG_ES512, JWT_ALG_TERM }
+ src/Libjwt/Flag.hs view
@@ -0,0 +1,135 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Support for simple sum types.+module Libjwt.Flag+ ( Flag(..)+ , AFlag(..)+ )+where++import Libjwt.ASCII++import Control.Applicative ( (<|>) )++import Data.Char ( toLower )+import Data.Coerce ( coerce )++import Data.Proxied ( conNameProxied )++import Data.Proxy++import GHC.Generics+import GHC.TypeLits++import Text.Casing++-- | Value that is encoded and decoded as 'AFlag'+--+-- Flags provide a way to automatically encode and decode simple sum types.+--+-- @+-- data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite+-- deriving stock (Show, Eq, Generic)+--+-- instance AFlag Scope+--+-- mkPayload = jwtPayload+-- (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+-- ( #user_name ->> "John Doe"+-- , #is_root ->> False+-- , #user_id ->> (12345 :: Int)+-- , #scope ->> Flag Login+-- )+-- @+newtype Flag a = Flag { getFlag :: a }+ deriving stock (Show, Eq)++-- | Types that can be used as /flags/ . That is, they support conversion to/from ASCII values,+-- for example, simple sum types are good candidates that can even be generically derived+--+--+-- @+-- data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite+-- deriving stock (Show, Eq, Generic)+--+-- instance AFlag Scope+-- @+--+-- >>> getFlagValue UserWrite+-- ASCII {getASCII = "userWrite"}+--+-- >>> setFlagValue (ASCII "userWrite") :: Maybe Scope+-- Just UserWrite+class AFlag a where+ getFlagValue :: a -> ASCII+ default getFlagValue :: (Generic a, GFlag (Rep a)) => a -> ASCII+ getFlagValue = ggetFlagValue . from++ setFlagValue :: ASCII -> Maybe a+ default setFlagValue :: (Generic a, GFlag (Rep a)) => ASCII -> Maybe a+ setFlagValue = fmap to . gsetFlagValue++instance AFlag a => AFlag (Flag a) where+ getFlagValue = getFlagValue . getFlag+ setFlagValue = coerce . setFlagValue @a++class GFlag f where+ ggetFlagValue :: f p -> ASCII+ gsetFlagValue :: ASCII -> Maybe (f p)++instance GFlag f => GFlag (D1 d f) where+ ggetFlagValue (M1 x) = ggetFlagValue x++ gsetFlagValue = fmap M1 . gsetFlagValue++instance (GFlag l, GFlag r) => GFlag (l :+: r) where+ ggetFlagValue (L1 x) = ggetFlagValue x+ ggetFlagValue (R1 x) = ggetFlagValue x++ gsetFlagValue string = tryL <|> tryR+ where+ tryL = L1 <$> gsetFlagValue string+ tryR = R1 <$> gsetFlagValue string++instance Constructor c => GFlag (C1 c U1) where+ ggetFlagValue _ = ASCII $ conNameToFlagValue c+ where c = conNameProxied (Proxy :: Proxy (C1 c U1 p))++ gsetFlagValue (ASCII flag) = if lower flag == lower c+ then Just (M1 U1)+ else Nothing+ where+ lower = map toLower+ c = conNameProxied (Proxy :: Proxy (C1 c U1 p))++conNameToFlagValue :: String -> String+conNameToFlagValue = toCamel . fromHumps++instance+ ( TypeError+ ( 'Text "Only sum types with empty constructors can be flags. For instance,"+ ':$$:+ 'Text "data Good = A | B | C is ok, but"+ ':$$:+ 'Text "data Bad = A Int String | B | C Char is not"+ )+ ) => GFlag (C1 c (any :*: thing)) where+ ggetFlagValue = error "unreachable"+ gsetFlagValue = error "unreachable"+++
+ src/Libjwt/Header.hs view
@@ -0,0 +1,75 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++-- | JWT header representation+module Libjwt.Header+ ( Alg(..)+ , Typ(..)+ , Header(..)+ )+where++import Libjwt.Encoding+import Libjwt.Keys+import Libjwt.FFI.Libjwt+import Libjwt.FFI.Jwt++import Control.Monad ( when )++import Data.ByteString ( ByteString )+import qualified Data.ByteString as ByteString++-- | @"alg"@ header parameter+data Alg = None+ -- | HMAC SHA-256 (secret key must be __at least 256 bits in size__)+ | HS256 Secret+ -- | HMAC SHA-384 (secret key must be __at least 384 bits in size__)+ | HS384 Secret+ -- | HMAC SHA-512 (secret key must be __at least 512 bits in size__)+ | HS512 Secret+ -- | RSASSA-PKCS1-v1_5 SHA-256 (a key of size __2048 bits or larger__ must be used with this algorithm)+ | RS256 RsaKeyPair+ -- | RSASSA-PKCS1-v1_5 SHA-384 (a key of size __2048 bits or larger__ must be used with this algorithm)+ | RS384 RsaKeyPair+ -- | RSASSA-PKCS1-v1_5 SHA-512 (a key of size __2048 bits or larger__ must be used with this algorithm)+ | RS512 RsaKeyPair+ -- | ECDSA with P-256 curve and SHA-256+ | ES256 EcKeyPair+ -- | ECDSA with P-384 curve and SHA-384+ | ES384 EcKeyPair+ -- | ECDSA with P-521 curve and SHA-512+ | ES512 EcKeyPair+ deriving stock (Show, Eq)++-- | @"typ"@ header parameter+data Typ = JWT | Typ (Maybe ByteString)+ deriving stock (Show, Eq)++-- | JWT header representation+data Header = Header { alg :: Alg, typ :: Typ }+ deriving stock (Show, Eq)++instance Encode Header where+ encode header jwt = encodeAlg (alg header) jwt >> encodeTyp (typ header) jwt+ where+ encodeAlg None = jwtSetAlg jwtAlgNone ByteString.empty >> forceTyp+ encodeAlg (HS256 secret) = jwtSetAlg jwtAlgHs256 $ reveal secret+ encodeAlg (HS384 secret) = jwtSetAlg jwtAlgHs384 $ reveal secret+ encodeAlg (HS512 secret) = jwtSetAlg jwtAlgHs512 $ reveal secret+ encodeAlg (RS256 pem ) = jwtSetAlg jwtAlgRs256 $ privKey pem+ encodeAlg (RS384 pem ) = jwtSetAlg jwtAlgRs384 $ privKey pem+ encodeAlg (RS512 pem ) = jwtSetAlg jwtAlgRs512 $ privKey pem+ encodeAlg (ES256 pem ) = jwtSetAlg jwtAlgEs256 $ ecPrivKey pem+ encodeAlg (ES384 pem ) = jwtSetAlg jwtAlgEs384 $ ecPrivKey pem+ encodeAlg (ES512 pem ) = jwtSetAlg jwtAlgEs512 $ ecPrivKey pem++ encodeTyp (Typ (Just s)) = addHeader "typ" s+ encodeTyp _ = nullEncode++ forceTyp = when (typ header == JWT) . addHeader "typ" "JWT"
+ src/Libjwt/JsonByteString.hs view
@@ -0,0 +1,50 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE DerivingStrategies #-}++-- | JSON string+module Libjwt.JsonByteString+ ( JsonByteString(..)+ , jsonFromStrict+ , toJsonStrict+ , toJsonBuilder+ )+where++import Data.ByteString ( ByteString )+import Data.ByteString.Builder ( Builder+ , lazyByteString+ )+import qualified Data.ByteString.Lazy as Lazy++-- | Represents a string which is already in JSON format. +--+-- Can be used for cases such as integration with /aeson/+-- +-- @+-- data Account = MkAccount { account_name :: Text, account_id :: UUID }+-- deriving stock (Show, Eq, Generic)+-- +-- instance FromJSON Account+-- instance ToJSON Account+-- +-- instance 'Libjwt.Classes.JwtRep' 'JsonByteString' Account where+-- rep = Json . encode+-- unRep = decode . toJson+-- @+newtype JsonByteString = Json { toJson :: Lazy.ByteString }+ deriving stock (Show, Eq)++jsonFromStrict :: ByteString -> JsonByteString+jsonFromStrict = Json . Lazy.fromStrict++toJsonStrict :: JsonByteString -> ByteString+toJsonStrict = Lazy.toStrict . toJson++toJsonBuilder :: JsonByteString -> Builder+toJsonBuilder = lazyByteString . toJson+++
+ src/Libjwt/Jwt.hs view
@@ -0,0 +1,259 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- | JWT representation, signing and decoding.++module Libjwt.Jwt+ ( Jwt(..)+ , Encoded+ , getToken+ , sign+ , signJwt+ , Decoded+ , getDecoded+ , decodeString+ , decodeByteString+ , Validated+ , getValid+ , validateJwt+ , jwtFromString+ , jwtFromByteString+ )+where++import Libjwt.Encoding+import Libjwt.Exceptions ( SomeDecodeException+ , AlgorithmMismatch(..)+ , DecodeException(..)+ )+import Libjwt.Decoding+import Libjwt.FFI.Jwt+import Libjwt.FFI.Libjwt+import Libjwt.Header+import Libjwt.JwtValidation+import Libjwt.Keys+import Libjwt.Payload+import Libjwt.PrivateClaims++import Control.Monad.Catch++import Control.Monad.Extra ( unlessM )++import Control.Monad.Time+import Control.Monad ( (<=<) )++import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as C8++import qualified Data.CaseInsensitive as CI++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )++import System.IO.Error ( ioeGetErrorType )++-- | JSON Web Token representation+data Jwt pc ns = Jwt { header :: Header, payload :: Payload pc ns }+deriving stock instance Show (PrivateClaims pc ns) => Show (Jwt pc ns)+deriving stock instance Eq (PrivateClaims pc ns) => Eq (Jwt pc ns)++instance Encode (PrivateClaims pc ns) => Encode (Jwt pc ns) where+ encode Jwt { header, payload } jwt = encode payload jwt >> encode header jwt++-- | base64url-encoded value of type @t@+newtype Encoded t = MkEncoded { getToken :: ByteString -- ^ octets of the UTF-8 representation+ }+ deriving stock (Show, Eq)++-- | Compute the encoded JWT value with the JWS Signature in the manner defined for the algorithm @alg@ .+-- 'typ' of the JWT 'Header' is set to "JWT"+--+-- Creates the serialized ouput, that is: +-- @+-- BASE64URL(UTF8(JWT Header)) || . || BASE64URL(JWT Payload) || . || BASE64URL(JWT Signature)+-- @+sign+ :: Encode (PrivateClaims pc ns) => Alg -> Payload pc ns -> Encoded (Jwt pc ns)+sign alg payload =+ signJwt $ Jwt { header = Header { alg, typ = JWT }, payload }++-- | Compute the encoded JWT value with the JWS Signature in the manner defined for the algorithm 'alg' present in the JWT's 'header' .+--+-- Creates the serialized ouput, that is: +-- @+-- BASE64URL(UTF8(JWT Header)) || . || BASE64URL(JWT Payload) || . || BASE64URL(JWT Signature)+-- @+signJwt :: Encode (PrivateClaims pc ns) => Jwt pc ns -> Encoded (Jwt pc ns)+signJwt it = MkEncoded $ unsafePerformJwtIO signTokenJwtIo+ where+ signTokenJwtIo = do+ jwt <- mkJwtT+ encode it jwt+ jwtEncode jwt++{-# NOINLINE signJwt #-}++-- | Decoded value of type @t@+newtype Decoded t = MkDecoded { getDecoded :: t }+ deriving stock (Show, Eq)++-- | See 'decodeByteString'+decodeString+ :: (MonadThrow m, Decode (PrivateClaims pc ns))+ => Alg+ -> String+ -> m (Decoded (Jwt pc ns))+decodeString alg = decodeByteString alg . C8.pack++-- | Parse the base64url-encoded representation to extract the serialized values for the components of the JWT.+-- Verify that:+-- +-- (1) @token@ is a valid UTF-8 encoded representation of a completely valid JSON object,+-- (1) input JWT signature matches,+-- (1) the correct algorithm was used,+-- (1) all required fields are present.+--+-- If steps 1-2 are unuccessful, 'DecodeException' will be thrown.+-- If step 3 fails, 'AlgorithmMismatch' will be thrown.+-- If the last step fails, 'Libjwt.Exceptions.MissingClaim' will be thrown.+decodeByteString+ :: forall ns pc m+ . (MonadThrow m, Decode (PrivateClaims pc ns))+ => Alg+ -> ByteString+ -> m (Decoded (Jwt pc ns))+decodeByteString alg token = either throwM (pure . MkDecoded)+ $ unsafePerformJwtIO decodeTokenJwtIo+ where+ decodeTokenJwtIo :: JwtIO (Either SomeDecodeException (Jwt pc ns))+ decodeTokenJwtIo = try $ do+ jwt <- safeJwtDecode alg token+ unlessM (matchAlg alg <$> jwtGetAlg jwt) $ throwM AlgorithmMismatch+ Jwt <$> decodeHeader jwt <*> decode jwt++ decodeHeader = fmap (Header alg) . decodeTyp++ decodeTyp =+ fmap+ ( maybe (Typ Nothing)+ $ \s -> if CI.mk s == "jwt" then JWT else Typ $ Just s+ )+ . getHeader "typ"++ matchAlg (HS256 _) = (== jwtAlgHs256)+ matchAlg (HS384 _) = (== jwtAlgHs384)+ matchAlg (HS512 _) = (== jwtAlgHs512)+ matchAlg (RS256 _) = (== jwtAlgRs256)+ matchAlg (RS384 _) = (== jwtAlgRs384)+ matchAlg (RS512 _) = (== jwtAlgRs512)+ matchAlg (ES256 _) = (== jwtAlgEs256)+ matchAlg (ES384 _) = (== jwtAlgEs384)+ matchAlg (ES512 _) = (== jwtAlgEs512)+ matchAlg None = (== jwtAlgNone)++{-# NOINLINE decodeByteString #-}++safeJwtDecode :: Alg -> ByteString -> JwtIO JwtT+safeJwtDecode alg token =+ catchIf (\e -> ioeGetErrorType e == InvalidArgument)+ (jwtDecode (getKey alg) token)+ $ const+ $ throwM+ $ DecodeException+ $ C8.unpack token+ where+ getKey (HS256 secret) = Just $ reveal secret+ getKey (HS384 secret) = Just $ reveal secret+ getKey (HS512 secret) = Just $ reveal secret+ getKey (RS256 pem ) = Just $ pubKey pem+ getKey (RS384 pem ) = Just $ pubKey pem+ getKey (RS512 pem ) = Just $ pubKey pem+ getKey (ES256 pem ) = Just $ ecPubKey pem+ getKey (ES384 pem ) = Just $ ecPubKey pem+ getKey (ES512 pem ) = Just $ ecPubKey pem+ getKey None = Nothing++-- | Successfully validated value of type @t@+newtype Validated t = MkValid { getValid :: t }+ deriving stock (Show, Eq)++-- | Accept or reject successfully decoded JWT value.+-- In addition to the default rules mandated by the RFC, the application can add its own rules.+--+-- The default rules are:+--+-- * check 'exp' claim to see if the current time is before the expiration time,+-- * check 'nbf' claim to see if the current time is after or equal the not-before time,+-- * check 'aud' claim if the application identifies itself with a value in the 'aud' list (if present)+--+-- You may allow a little 'leeway' when checking time-based claims.+--+-- 'aud' claim is checked against 'appName'.+validateJwt+ :: MonadTime m+ => ValidationSettings -- ^ 'leeway' and 'appName'+ -> JwtValidation pc ns -- ^ additional validation rules+ -> Decoded (Jwt pc ns) -- ^ decoded token+ -> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns)))+validateJwt settings v (MkDecoded jwt) =+ fmap (MkValid jwt <$) $ runValidation settings v $ payload jwt++-- | See 'jwtFromByteString'+jwtFromString+ :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m)+ => ValidationSettings+ -> JwtValidation pc ns+ -> Alg+ -> String+ -> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns)))+jwtFromString settings v alg = validateJwt settings v <=< decodeString alg++-- | @jwtFromByteString = 'validateJwt' settings v <=< 'decodeByteString' alg@+--+-- In other words, it:+-- +-- Parses the base64url-encoded representation to extract the serialized values for the components of the JWT.+-- Verifies that:+-- +-- (1) @token@ is a valid UTF-8 encoded representation of a completely valid JSON object,+-- (1) input JWT signature matches,+-- (1) the correct algorithm was used,+-- (1) all required fields are present.+--+-- If steps 1-2 are unuccessful, 'DecodeException' will be thrown.+-- If step 3 fails, 'AlgorithmMismatch' will be thrown.+-- If the last step fails, 'Libjwt.Exceptions.MissingClaim' will be thrown.+-- +-- Once the token has been successfully decoded, it is validated.+--+-- In addition to the default rules mandated by the RFC, the application can add its own rules.+--+-- The default rules are:+--+-- * check 'exp' claim to see if the current time is before the expiration time,+-- * check 'nbf' claim to see if the current time is after or equal the not-before time,+-- * check 'aud' claim if the application identifies itself with a value in the 'aud' list (if present)+--+-- You may allow a little 'leeway' when checking time-based claims.+--+-- 'aud' claim is checked against 'appName'.+jwtFromByteString+ :: (Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m)+ => ValidationSettings -- ^ 'leeway' and 'appName'+ -> JwtValidation pc ns -- ^ additional validation rules + -> Alg -- ^ algorithm used to verify the signature+ -> ByteString -- ^ base64url-encoded representation (a token)+ -> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns)))+jwtFromByteString settings v alg =+ validateJwt settings v <=< decodeByteString alg+
+ src/Libjwt/JwtValidation.hs view
@@ -0,0 +1,247 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}++-- | Validation of JWT claims++module Libjwt.JwtValidation+ ( ValidationSettings(..)+ , defaultValidationSettings+ , runValidation+ , ValidationNEL+ , Valid+ , Check+ , JwtValidation+ , validation+ , invalid+ , valid+ , checkIssuer+ , checkSubject+ , checkAge+ , checkIssuedAfter+ , checkJwtId+ , checkClaim+ , check+ , ValidationFailure(..)+ )+where++import Libjwt.NumericDate+import Libjwt.Payload+import Libjwt.PrivateClaims+import Libjwt.RegisteredClaims++import Control.Monad.Time++import Control.Monad.Trans.Reader++import Data.Coerce ( coerce )++import Data.Either.Validation ( Validation(..) )++import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Monoid ( Ap(..) )++import Data.Time.Clock++import Data.UUID ( UUID )++import Prelude hiding ( exp )++type ValidationNEL a b = Validation (NonEmpty a) b++data ValidationEnv = Env { timestamp :: NumericDate+ , settings :: ValidationSettings+ }++-- | User-defined parameters of an validation+data ValidationSettings = Settings { leeway :: NominalDiffTime -- ^ extends the token validity period to /['nbf' - leeway, 'exp' + leeway)/ (also works for 'iat' checks such as 'checkAge')+ , appName :: Maybe String -- ^ used for 'aud' checks: if 'aud' claim is present, it must contain the value of this param+ }+ deriving stock Show++-- | 'ValidationSettings' with 'leeway' set to @0@ and 'appName' set to @Nothing@+defaultValidationSettings :: ValidationSettings+defaultValidationSettings = Settings { leeway = 0, appName = Nothing }++-- | Reasons for rejecting a JWT token+data ValidationFailure -- | User check failed + = InvalidClaim String+ -- | /exp/ check failed: the current time was after or equal to the expiration time (plus possible 'leeway')+ | TokenExpired NominalDiffTime+ -- | /nbf/ check failed: the current time was before the not-before time (minus possible 'leeway')+ | TokenNotReady NominalDiffTime+ -- | /aud/ check failed: the application processing this claim did not identify itself ('appName') with a value in the /aud/ claim+ | WrongRecipient+ -- | /iat/ check failed: the current time minus the time the JWT was issued (plus possible 'leeway') was greater than expected+ | TokenTooOld NominalDiffTime+ deriving stock (Show, Eq)++data Valid = Valid+ deriving stock Show++instance Semigroup Valid where+ Valid <> Valid = Valid++type Check pc ns = Payload pc ns -> ValidationNEL ValidationFailure Valid++type CheckAp pc ns+ = Payload pc ns -> Ap (Validation (NonEmpty ValidationFailure)) Valid++-- | Construct validation from function+validation :: Check pc any -> JwtValidation pc any+validation = MkValidation . Ap . pure . coerce++-- | Validation that is always valid+valid :: ValidationNEL ValidationFailure Valid+valid = Success Valid++-- | Validation that always fails and signals @reason@+invalid+ :: ValidationFailure -- ^ reason+ -> ValidationNEL ValidationFailure Valid+invalid reason = Failure $ reason :| []++newtype JwtValidation pc any = MkValidation { rules :: Ap (Reader ValidationEnv) (CheckAp pc any) }+ deriving newtype (Semigroup)++instance Monoid (JwtValidation any1 any2) where+ mempty = validation $ const valid++-- | Run checks against the @payload@.+--+-- The exact set of checks is: @ defaultValidationRules <> v @, where @v@ is passed to this function and @defaultValidationRules@ is:+--+-- * check /exp/ claim against the current time (minus possible 'leeway'),+-- * check /nbf/ claim against the current time (plus possible 'leeway'),+-- * check /aud/ claim against 'appName'+--+-- See the docs of 'ValidationFailure' for a list of possible errors.+runValidation+ :: (MonadTime m)+ => ValidationSettings -- ^ /leeway/ and /appName/+ -> JwtValidation pc any -- ^ v+ -> Payload pc any -- ^ payload+ -> m (ValidationNEL ValidationFailure Valid)+runValidation settings v payload =+ let MkValidation { rules } = defaultValidationRules <> v+ applyRules = runReader (getAp rules)+ in do+ timestamp <- now+ let env = Env { timestamp, settings }+ return $ getAp $ applyRules env payload++defaultValidationRules :: JwtValidation any1 any2+defaultValidationRules = _checkExp <> _checkNbf <> _checkAud++using+ :: (ValidationEnv -> a) -> (a -> JwtValidation pc any) -> JwtValidation pc any+using get v = coerce (getAp . rules . v =<< asks get)++-- | Check the property @prop@ of a payload with the predicate @p@+--+-- If @p@ is @False@, then signal @'InvalidClaim' claim@+check+ :: String -- ^ claim+ -> (a -> Bool) -- ^ p+ -> (Payload pc any -> a) -- ^ prop+ -> JwtValidation pc any+check claim p prop =+ validation+ $ (\a -> if p a then valid else invalid $ InvalidClaim claim)+ . prop++-- | Check that /iss/ is present and equal to @issuer@. If not, then signal @'InvalidClaim' "iss"@+checkIssuer+ :: String -- ^ issuer+ -> JwtValidation any1 any2+checkIssuer issuer = check "iss" (== Iss (Just issuer)) iss++-- | Check that /sub/ is present and equal to @subject@. If not, then signal @'InvalidClaim' "sub"@+checkSubject+ :: String -- ^ subject + -> JwtValidation any1 any2+checkSubject subject = check "sub" (== Sub (Just subject)) sub++_checkAud :: JwtValidation any1 any2+_checkAud = using (appName . settings)+ $ \ident -> validation $ rfc7519_413 ident . aud+ where+ rfc7519_413 _ (Aud []) = valid+ rfc7519_413 Nothing _ = invalid WrongRecipient+ rfc7519_413 (Just ident) (Aud rs) | ident `elem` rs = valid+ | otherwise = invalid WrongRecipient++_checkExp :: JwtValidation any1 any2+_checkExp = using (leeway . settings)+ $ \skew -> using timestamp $ \t0 -> validation $ rfc7519_414 t0 skew . exp+ where+ rfc7519_414 _ _ (Exp Nothing) = valid+ rfc7519_414 t0 skew (Exp (Just t1))+ | t0 `minusSeconds` skew < t1 = valid+ | otherwise = invalid $ TokenExpired $ diffSeconds t0 t1++_checkNbf :: JwtValidation any1 any2+_checkNbf = using (leeway . settings)+ $ \skew -> using timestamp $ \t0 -> validation $ rfc7519_415 t0 skew . nbf+ where+ rfc7519_415 _ _ (Nbf Nothing) = valid+ rfc7519_415 t0 skew (Nbf (Just t1))+ | t0 `plusSeconds` skew >= t1 = valid+ | otherwise = invalid $ TokenNotReady $ diffSeconds t1 t0++-- | Check that /iat/ (if present) is not further than @maxAge@ from 'currentTime' (minus possible 'leeway'). Otherwise signal 'TokenTooOld'.+checkAge+ :: NominalDiffTime -- ^ maxAge + -> JwtValidation any1 any2+checkAge maxAge = using (leeway . settings)+ $ \skew -> using timestamp $ \t0 -> validation $ ageCheck t0 skew . iat+ where+ ageCheck _ _ (Iat Nothing) = valid+ ageCheck t0 skew (Iat (Just t1))+ | age <= maxAge = valid+ | otherwise = invalid $ TokenTooOld $ age - maxAge+ where age = diffSeconds t0 $ t1 `plusSeconds` skew++-- | Check that /iat/ (if present) is after @time@. If false, signal @'InvalidClaim' "iat"@.+checkIssuedAfter+ :: UTCTime -- ^ time+ -> JwtValidation any1 any2+checkIssuedAfter time = check+ "iat"+ (\case+ Iat Nothing -> True+ Iat (Just t1) -> t1 > fromUTC time+ )+ iat++-- | Check that /jti/ is present and equal to @jwtId@. If not, then signal @'InvalidClaim' "jti"@+checkJwtId+ :: UUID -- ^ jwtId+ -> JwtValidation any1 any2+checkJwtId jwtId = check "jti" (== Jti (Just jwtId)) jti++-- | Check that @p a == True@, where @a@ is a value of private claim @n@. If not, signal @'InvalidClaim' n@+-- +-- Example:+-- +-- @+-- 'checkClaim' not #is_root+-- @+checkClaim+ :: (CanGet n pc, a ~ LookupClaimType n pc)+ => (a -> Bool) -- ^ p+ -> ClaimName n -- ^ n+ -> JwtValidation pc any+checkClaim p n = check (claimNameVal n) p (getClaim n . privateClaims)+++
+ src/Libjwt/Keys.hs view
@@ -0,0 +1,134 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}++-- | Keys used for signing and validation+module Libjwt.Keys+ ( Secret(..)+ , RsaKeyPair(..)+ , EcKeyPair(..)+ )+where++import Data.ByteString ( ByteString )++import qualified Data.ByteString.UTF8 as UTF8++import Data.String++-- | Secret used in /HMAC/ algorithms.+-- +-- According to RFC:+-- /A key of the same size as the hash output (for instance, 256 bits for 'HS256') or larger MUST be used (...)/ +-- - the user must ensure this property holds.+--+-- A secret is just an octet sequence e.g.+--+-- @+-- hs512 =+-- HS512+-- "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\\+-- \\YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\\+-- \\Y2IwMDZhYWY1MjY1OTQgIC0K"+-- @+newtype Secret = MkSecret { reveal :: ByteString }+ deriving stock (Show, Eq)++instance IsString Secret where+ fromString = MkSecret . UTF8.fromString++-- | RSA key-pair used in /RSA/ algorithms+--+-- According to RFC:+-- /A key of size 2048 bits or larger MUST be used with these algorithms./ +-- - the user must ensure this property holds.+--+-- Both fields are assumed to be strings representing /PEM-encoded/ keys+--+-- >+-- >rsa2048KeyPair =+-- > let private = C8.pack $ unlines+-- > [ "-----BEGIN RSA PRIVATE KEY-----"+-- > , "MIIEpgIBAAKCAQEAwCXp2P+qboao0tjUyU+D3YI+sgBn8dkGaxOvPFLBFQMNkhbL"+-- > , "0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclROXocRWUn5s2W3jP5xn7lM4otIpuE"+-- > , "3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHVEuGMM7oddiB6s3zjwf2h1v0SEiHf"+-- > , "5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3JcaWW+eDk/UU3jCfCke7R3t2rbD1ZC"+-- > , "j1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcpd8iz0ZTLaG8Qnm0GsPQjR3PTZYEC"+-- > , "xEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5YboxQIDAQABAoIBAQCg/OMBsauc8Ovv"+-- > , "xEX76MglxeM7hgWQ5vFus05lrzwgm686EClxme1QHMv8QszuXzSjuEFs4SQH9K82"+-- > , "p2z+UgrgqkOXjNoykVvvDgMe4OCuHv4T+dMGO1hTrXfXawKI2Lhg1/1bzX+u5ii9"+-- > , "mfbsUUixihHKoQvgFfRX/7JfrV50XZ3diwzd8DoEaIgeAIdyhLhVuh2W7wXbOF+l"+-- > , "aZW7gqCVzTBhC04E/D6eqFqvnkQyHzZPgaaDi4oL7gP8nGpcswlqKSLO5eVkkEHY"+-- > , "C88nAwU4Q/+qcAf09ijmTLlo07xLrLC0cOf2yQTwLj6ZffzTJ7NSMaPrTdEXThsW"+-- > , "wAeB/GcBAoGBAOzLST9/zakFGBTkwiLqgNVgEBUoYjB0Z+Fpx4qBLzKZNQP1yNup"+-- > , "LhC/4pIVQM+ZjOS0Wx7Sh0FTLHFb018quPiAPsKMEC2CW5v7vKwC4zW72/v5UrIw"+-- > , "pcBzl67nsc53r5Lblol9PU4oCjDzuFMjMbg+EzD3kVp/gxC9bRMwK3zBAoGBAM+7"+-- > , "nOV80uteB1ZXazccj6g0ANd2AyJY6gHfxD1CopvRReYm36wmG00HQ3jHZPUcsLQp"+-- > , "dWvWplRFprZlce0jl7HcB/8g5wUkErMop3KK5cA886HxsATNSl6rYghZGALqxm/a"+-- > , "+v2AKoZThns8QRYL5bsBD4kTQLEIwp7j6sNbBrkFAoGBAL6fL8o0gkUsWqSHO1mM"+-- > , "WkZrXMcLiW/kZbPqyb3QHUSoXStg818RpInLTwO2pEP7IpcCMdBwPn3yDPb8qv4T"+-- > , "kHBMHTnUMznPlRvO3aXDdVFOd9sybMYRr31sEJG250aExwx8RYVNEssWJI4fxST4"+-- > , "UhA1uJFU2uh1efdB5srpnjiBAoGBALTDCPAZAmCVXcUgJMe8LrWrKuBSbL/Cpz4i"+-- > , "PV0hUuZL4Is5YIEoV7FblLbQq2UvJgRf3zGLgwjp4vvsooo74pB+auby9pReo3cK"+-- > , "9UqS2wHBCC/vY7+J9CEU+SVSgbZoHWzQHH/iux5QKEGsWOaaS7nCXoZlHnHusYwZ"+-- > , "v/tmhh8RAoGBAIi3Lbup0AVwougANLXwMLCfT8HxI8Hozdr+Pe0ibTnjfY+BPuy1"+-- > , "vSgozXao68TwW3u58PcdvfBnfg/7XCK6TXtij48JDu6qw0IiSRxOZ5Ed/GW2P031"+-- > , "7TfwnjBohjM2O6NRne8qe6Qv5xLagoVKQfa1WhQEFU2bTNLYA/2kv266"+-- > , "-----END RSA PRIVATE KEY-----"+-- > ]+-- > public = C8.pack $ unlines+-- > [ "-----BEGIN PUBLIC KEY-----"+-- > , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D"+-- > , "3YI+sgBn8dkGaxOvPFLBFQMNkhbL0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclR"+-- > , "OXocRWUn5s2W3jP5xn7lM4otIpuE3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHV"+-- > , "EuGMM7oddiB6s3zjwf2h1v0SEiHf5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3Jc"+-- > , "aWW+eDk/UU3jCfCke7R3t2rbD1ZCj1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcp"+-- > , "d8iz0ZTLaG8Qnm0GsPQjR3PTZYECxEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5Ybo"+-- > , "xQIDAQAB"+-- > , "-----END PUBLIC KEY-----"+-- > ]+-- > in FromRsaPem { privKey = private, pubKey = public }+data RsaKeyPair = FromRsaPem { privKey :: ByteString, pubKey :: ByteString }+ deriving stock (Show, Eq)++-- | Elliptic curves parameters used in /ECDSA/ algorithms+--+-- According to RFC, the following curves are to be used:+--+-- +-------------------+-------------------------------++-- | "alg" Param Value | Digital Signature Algorithm |+-- +===================+===============================++-- | ES256 | ECDSA using P-256 and SHA-256 |+-- +-------------------+-------------------------------++-- | ES384 | ECDSA using P-384 and SHA-384 |+-- +-------------------+-------------------------------++-- | ES512 | ECDSA using P-521 and SHA-512 |+-- +-------------------+-------------------------------++--+-- It is up to the user to use the appropriate curves.+--+-- The following names are used in OpenSSL: /prime256v1/, /secp384r1/ and /secp521r1/+--+-- Curve parametrs should be /PEM-encoded/ strings+--+-- > ecP256KeyPair =+-- > let private = C8.pack $ unlines+-- > [ "-----BEGIN EC PRIVATE KEY-----"+-- > , "MHcCAQEEINQ0e0KOa3EZSB5RTd2xBuO3O7NNFietDIWl+B+R38LuoAoGCCqGSM49"+-- > , "AwEHoUQDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FNlsrCnaXRoJUVdOYZldzb4po2"+-- > , "uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+-- > , "-----END EC PRIVATE KEY-----"+-- > ]+-- > public = C8.pack $ unlines+-- > [ "-----BEGIN PUBLIC KEY-----"+-- > , "MFkwEwYHKoZIzj0CAQYIKoZIzj0DAQcDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FN"+-- > , "lsrCnaXRoJUVdOYZldzb4po2uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+-- > , "-----END PUBLIC KEY-----"+-- > ]+-- > in FromEcPem { ecPrivKey = private, ecPubKey = public }+data EcKeyPair = FromEcPem { ecPrivKey :: ByteString, ecPubKey :: ByteString }+ deriving stock (Show, Eq)
+ src/Libjwt/NumericDate.hs view
@@ -0,0 +1,59 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE DerivingStrategies #-}++-- | POSIX seconds+module Libjwt.NumericDate+ ( NumericDate(..)+ , fromUTC+ , fromPOSIX+ , toPOSIX+ , now+ , plusSeconds+ , minusSeconds+ , diffSeconds+ )+where++import Control.Monad.Time++import Data.Int++import Data.Time.Clock ( NominalDiffTime+ , UTCTime+ )+import Data.Time.Clock.POSIX ( POSIXTime+ , utcTimeToPOSIXSeconds+ )+-- | Represents the number of seconds elapsed since 1970-01-01+--+-- Used in accordance with the RFC in 'Libjwt.RegisteredClaims.Exp', 'Libjwt.RegisteredClaims.Nbf' and 'Libjwt.RegisteredClaims.Iat' claims+newtype NumericDate = NumericDate { secondsSinceEpoch :: Int64 }+ deriving stock (Show, Eq, Ord, Bounded)++fromPOSIX :: POSIXTime -> NumericDate+fromPOSIX = NumericDate . truncate++fromUTC :: UTCTime -> NumericDate+fromUTC = fromPOSIX . utcTimeToPOSIXSeconds++toPOSIX :: NumericDate -> POSIXTime+toPOSIX (NumericDate s) = fromIntegral s++-- | Convert 'currentTime' to a number of seconds since 1970-01-01+now :: (MonadTime m) => m NumericDate+now = fromUTC <$> currentTime++-- | Add some seconds to the date+plusSeconds :: NumericDate -> NominalDiffTime -> NumericDate+plusSeconds d s = NumericDate $ secondsSinceEpoch d + round s++-- | Subtract some seconds from the date+minusSeconds :: NumericDate -> NominalDiffTime -> NumericDate+minusSeconds d s = plusSeconds d (-s)++-- | The number of seconds between two dates+diffSeconds :: NumericDate -> NumericDate -> NominalDiffTime+diffSeconds a b = toPOSIX a - toPOSIX b
+ src/Libjwt/Payload.hs view
@@ -0,0 +1,256 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | JWT payload structure and convenient builders.+module Libjwt.Payload+ ( Payload(..)+ , withIssuer+ , issuedBy+ , withSubject+ , issuedTo+ , withRecipient+ , intendedFor+ , withAudience+ , setTtl+ , expiresAt+ , notBefore+ , notBeforeNow+ , notUntil+ , issuedNow+ , withJwtId+ , JwtBuilder+ , jwtPayload+ )+where++import Libjwt.Encoding+import Libjwt.Decoding+import Libjwt.NumericDate+import Libjwt.RegisteredClaims+import Libjwt.PrivateClaims++import Control.Monad.Time++import Control.Monad.Trans.Reader++import Data.Default++import Data.Function ( (&) )+import Data.Monoid++import Data.Time.Clock++import Data.UUID ( UUID )++import Prelude hiding ( exp )++-- | JWT payload representation+data Payload pc ns = ClaimsSet { iss :: Iss -- ^ /iss/ (Issuer) claim+ , sub :: Sub -- ^ /sub/ (Subject) claim+ , aud :: Aud -- ^ /aud/ (Audience) claim+ , exp :: Exp -- ^ /exp/ (Expiration Time) claim+ , nbf :: Nbf -- ^ /nbf/ (Not Before) claim+ , iat :: Iat -- ^ /iat/ (Issued At) claim+ , jti :: Jti -- ^ /jti/ (JWT ID) claim+ , privateClaims :: PrivateClaims pc ns -- ^ private claims+ }+deriving stock instance Show (PrivateClaims pc ns) => Show (Payload pc ns)+deriving stock instance Eq (PrivateClaims pc ns) => Eq (Payload pc ns)++instance (pc ~ Empty, ns ~ 'NoNs) => Default (Payload pc ns) where+ def = ClaimsSet { iss = def+ , sub = def+ , aud = mempty+ , exp = def+ , nbf = def+ , iat = def+ , jti = def+ , privateClaims = def+ }++instance Encode (PrivateClaims pc ns) => Encode (Payload pc ns) where+ encode ClaimsSet { iss, sub, aud, exp, nbf, iat, jti, privateClaims } jwt =+ encode iss jwt+ >> encode sub jwt+ >> encode aud jwt+ >> encode exp jwt+ >> encode nbf jwt+ >> encode iat jwt+ >> encode jti jwt+ >> encode privateClaims jwt++instance Decode (PrivateClaims pc ns) => Decode (Payload pc ns) where+ decode jwt =+ ClaimsSet+ <$> decode jwt+ <*> decode jwt+ <*> decode jwt+ <*> decode jwt+ <*> decode jwt+ <*> decode jwt+ <*> decode jwt+ <*> decode jwt++newtype JwtBuilder any1 any2 = JwtBuilder { steps :: Ap (Reader UTCTime) (Endo (Payload any1 any2)) }+ deriving newtype (Semigroup, Monoid)++-- | Create a payload from the builder and the value representing private claims+--+-- For example:+-- +-- @+-- jwtPayload+-- ('withIssuer' "myApp" <> 'withRecipient' "https://myApp.com" <> 'setTtl' 300)+-- ( #userName v'->>' "John Doe"+-- , #isRoot v'->>' False+-- , #userId v'->>' (12345 :: Int)+-- )+-- @+-- +-- The resulting payload will be the equivalent of:+-- +-- > {+-- > "aud": [+-- > "https://myApp.com"+-- > ],+-- > "exp": 1599499073,+-- > "iat": 1599498773,+-- > "isRoot": false,+-- > "iss": "myApp",+-- > "userId": 12345,+-- > "userName": "JohnDoe"+-- > }+--+-- An identical payload can be constructed from the following record type:+--+-- @+-- data MyClaims = MyClaims { userName :: String+-- , isRoot :: Bool+-- , userId :: Int+-- }+-- deriving stock (Eq, Show, Generic)+-- +-- instance 'ToPrivateClaims' UserClaims+-- +-- jwtPayload+-- ('withIssuer' "myApp" <> 'withRecipient' "https://myApp.com" <> 'setTtl' 300)+-- MyClaims { userName = "John Doe"+-- , isRoot = False+-- , userId = 12345+-- }+-- @+-- +-- If you want to assign a /namespace/ to your private claims, you can do:+-- +-- @+-- jwtPayload+-- (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+-- $ 'withNs'+-- ('Ns' @"https://myApp.com")+-- MyClaims+-- { userId = 12345+-- , userName = "JohnDoe"+-- , isRoot = False+-- }+-- @+--+-- The resulting payload will be the equivalent of:+-- +-- > {+-- > "aud": [+-- > "https://myApp.com"+-- > ],+-- > "exp": 1599499073,+-- > "iat": 1599498773,+-- > "https://myApp.com/isRoot": false,+-- > "iss": "myApp",+-- > "https://myApp.com/userId": 12345,+-- > "https://myApp.com/userName": "JohnDoe"+-- > }+jwtPayload+ :: (MonadTime m, ToPrivateClaims a, Claims a ~ b, OutNs a ~ ns)+ => JwtBuilder b ns+ -> a+ -> m (Payload b ns)+jwtPayload builder a =+ (&) initial . appEndo . runReader (getAp $ steps builder) <$> currentTime+ where initial = def { privateClaims = toPrivateClaims a }++step :: (Payload any1 any2 -> Payload any1 any2) -> JwtBuilder any1 any2+step = JwtBuilder . Ap . pure . Endo++stepWithCurrentTime+ :: (NumericDate -> Payload any1 any2 -> Payload any1 any2)+ -> JwtBuilder any1 any2+stepWithCurrentTime f = JwtBuilder . Ap $ fmap (Endo . f) now++-- | Set /iss/ claim+withIssuer :: String -> JwtBuilder any1 any2+withIssuer issuer = step $ \p -> p { iss = Iss $ Just issuer }++-- | Set /iss/ claim+issuedBy :: String -> JwtBuilder any1 any2+issuedBy = withIssuer++-- | Set /sub/ claim+withSubject :: String -> JwtBuilder any1 any2+withSubject subject = step $ \p -> p { sub = Sub $ Just subject }++-- | Set /sub/ claim+issuedTo :: String -> JwtBuilder any1 any2+issuedTo = withSubject++-- | Append one item to /aud/ claim+withRecipient :: String -> JwtBuilder any1 any2+withRecipient recipient = step $ \p -> p { aud = Aud [recipient] <> aud p }++-- | Append one item to /aud/ claim+intendedFor :: String -> JwtBuilder any1 any2+intendedFor = withRecipient++-- | Set /aud/ claim+withAudience :: [String] -> JwtBuilder any1 any2+withAudience audience = step $ \p -> p { aud = Aud audience }++-- | Set /exp/ claim+expiresAt :: UTCTime -> JwtBuilder any1 any2+expiresAt time = step $ \p -> p { exp = Exp $ Just $ fromUTC time }++-- | Set /nbf/ claim+notBefore :: UTCTime -> JwtBuilder any1 any2+notBefore time = step $ \p -> p { nbf = Nbf $ Just $ fromUTC time }++-- | Set /nbf/ claim to 'currentTime'+notBeforeNow :: JwtBuilder any1 any2+notBeforeNow = stepWithCurrentTime $ \t p -> p { nbf = Nbf $ Just t }++-- | Set /nbf/ claim to 'currentTime' plus the argument+notUntil :: NominalDiffTime -> JwtBuilder any1 any2+notUntil s =+ stepWithCurrentTime $ \t p -> p { nbf = Nbf $ Just $ t `plusSeconds` s }++-- | Set /iat/ claim to 'currentTime'+issuedNow :: JwtBuilder any1 any2+issuedNow = stepWithCurrentTime $ \t p -> p { iat = Iat $ Just t }++-- | Set /iat/ claim to 'currentTime' and /exp/ claim to 'currentTime' plus the argument+setTtl :: NominalDiffTime -> JwtBuilder any1 any2+setTtl ttl = issuedNow <> stepWithCurrentTime+ (\t p -> p { exp = Exp $ Just $ t `plusSeconds` ttl })++-- | Set /jti/ claim+withJwtId :: UUID -> JwtBuilder any1 any2+withJwtId jwtId = step $ \p -> p { jti = Jti $ Just jwtId }
+ src/Libjwt/PrivateClaims.hs view
@@ -0,0 +1,800 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_GHC -Wno-missing-methods #-}+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | Collection of functions, types and type families that are needed to implement type-safe private claims.+--+-- This is essentially an implementation of /open product/ type as described in Sandy Maguire "Thinking with Types".+-- The only difference to the book is that the implementation is backed by HashMap to make lookups by name easier.+-- In addition, there are also 'FromPrivateClaims' and 'ToPrivateClaims' type-classes and +-- /view pattern/ ':<' to help create and deconstruct values.+module Libjwt.PrivateClaims+ ( + -- * Kinds+ Claim(..)+ , type (->>)+ , Namespace(..)+ , KnownNamespace(..)+ -- * Value-level counterparts+ , ClaimName(..)+ , claimNameVal+ , Ns(..)+ , ClaimWitness+ , testify+ , (->>)+ -- * Private claims type+ , PrivateClaims+ , type Empty+ -- * Construction+ , nullClaims+ , addClaim+ , (.:)+ , CanAdd+ , RestrictedName+ -- * Lookup+ , getClaim+ , (.!)+ , CanGet+ , LookupClaimType+ -- * Patern matching+ , pattern (:<)+ -- * Namespaces+ , withNs+ , someNs+ , noNs+ -- * Conversions+ , ToPrivateClaims(..)+ , FromPrivateClaims(..)+ )+where++import Libjwt.Encoding+import Libjwt.Decoding+import Libjwt.FFI.Jwt (JwtT)++import Control.Applicative ( liftA2 )+import Data.Coerce++import Data.Default++import Data.HashMap.Lazy ( HashMap+ , (!)+ )+import qualified Data.HashMap.Lazy as HashMap++import Data.Kind++import Data.Proxied ( selNameProxied )++import Data.Proxy++import GHC.Generics+import GHC.OverloadedLabels+import GHC.Show+import GHC.TypeLits+import Unsafe.Coerce ( unsafeCoerce )++infix 6 ->>+infixr 5 .:+infixr 5 :<++-- | Kind of claims+-- +-- A claim is made up of a type-level literal and a type (this is essentialy a /type-level tuple/ @(Symbol, *)@)+data Claim (a :: Type) = Grant Symbol a++-- | A convenient alias.+-- Let's you write @'["claimName" ->> Int, "anotherName" ->> String]@ to indicate a list of types of kind 'Claim',+-- instead of @'[Grant "claimName" Int, Grant "anotherName" String]@,+-- +type name ->> a = 'Grant name a++-- | Kind of namespaces+--+-- These types represent a URL-like claim prefix+data Namespace = NoNs | SomeNs Symbol++-- | Class of 'Namespace' with known compile-time value+class KnownNamespace (ns :: Namespace) where+ -- | Convert namespace to a string (if any)+ namespaceValue :: proxy ns -> Maybe String++instance KnownNamespace 'NoNs where+ namespaceValue _ = Nothing++instance KnownSymbol ns => KnownNamespace ('SomeNs ns) where+ namespaceValue _ = Just $ symbolVal (Proxy :: Proxy ns)++fullClaimName :: (KnownNamespace ns) => proxy ns -> String -> String+fullClaimName p claimName =+ maybe claimName (++ '/' : claimName) $ namespaceValue p+{-# INLINE fullClaimName #-}++fullClaimName' :: forall ns name . (KnownNamespace ns, KnownSymbol name) => String+fullClaimName' = fullClaimName (Proxy :: Proxy ns) $ symbolVal (Proxy :: Proxy name)++-- | Type-level literal representing a claim name+--+-- Can be used with @-XOverloadedLabels@+data ClaimName (name :: Symbol) = ClaimName++instance (name ~ name') => IsLabel name (ClaimName name') where+ fromLabel = ClaimName++-- | Retrieve the string associated with 'ClaimName'+claimNameVal :: forall name . KnownSymbol name => ClaimName name -> String+claimNameVal _ = symbolVal (Proxy :: Proxy name)++-- | Type-level literal representing a namespace+--+-- Can be used with @-XOverloadedLabels@ +-- (the limited label syntax makes this rarely possibble though, a more common use is to write /Ns @"https://example.com"/)+data Ns (ns :: Symbol) = Ns++instance (name ~ name') => IsLabel name (Ns name') where+ fromLabel = Ns++-- | Keeps the value of type @a@ and the name (type-level) with which it is associated+newtype ClaimWitness (name :: Symbol) a = Witness { testify :: a }++-- | Associate @name@ with a value+--+-- With @-XOverloadedLabels@+--+-- >>> :t #someName ->> True+-- #someName ->> True :: ClaimWitness "someName" Bool+(->>) :: ClaimName name -> a -> ClaimWitness name a+_ ->> a = Witness a++data Any = forall a . Any a++-- | Container of named claims @ts@, possibly prefixed with some namespace @ns@+-- +-- For example @PrivateClaims '["string" t'->>' String, "int" t'->>' Int] ''NoNs'@ denotes a structure containing+-- a String under the "string" key plus an int under the "int" key.+-- There is no namespace, so the keys will not be prefixed by any prefix when serializing the structure+newtype PrivateClaims (ts :: [Claim Type]) (ns :: Namespace) = PrivateClaims { unsafeClaimsMap :: HashMap String Any }++type Empty = ('[] :: [Claim Type])++-- | Empty claims+nullClaims :: PrivateClaims Empty 'NoNs+nullClaims = PrivateClaims HashMap.empty++-- | Insert the claim.+--+-- The claim can be safely added iff:+--+-- * there is no claim of the same @name@ in the container,+-- * its name is not the name of any public claim (like /iss/ or /sub/)+--+-- Otherwise it is a compile-time error (see 'CanAdd' constraint)+-- +-- With @-XOverloadedLabels@+--+-- >>> addClaim #string "Value of claim" nullClaims+-- (#string ->> "Value of claim")+--+-- With @-XTypeApplications@ and @-XDataKinds@+--+-- >>> addClaim (ClaimName @"string") "Value of claim" nullClaims+-- (#string ->> "Value of claim")+addClaim+ :: forall name a ts ns+ . CanAdd name ts+ => ClaimName name+ -> a+ -> PrivateClaims ts ns+ -> PrivateClaims (name ->> a : ts) ns+addClaim _ a (PrivateClaims store) = PrivateClaims+ $ HashMap.insert claimName (Any a) store+ where claimName = symbolVal (Proxy :: Proxy name)++-- | Alias for 'addClaim' (binds to the right)+--+-- With @-XOverloadedLabels@+--+-- >>> #string ->> "Value of claim" .: nullClaims+-- (#string ->> "Value of claim")+(.:)+ :: forall name a ts ns+ . CanAdd name ts+ => ClaimWitness name a+ -> PrivateClaims ts ns+ -> PrivateClaims (name ->> a : ts) ns+(Witness a) .: pc = addClaim ClaimName a pc++-- | Constraint specifying when a claim named @n@ can be added to the list of claims @ns@+--+-- Satisfied iff:+--+-- * @n@ is a type-level literal,+-- * in the names of @ns@ claims there is no @n@ (uniqueness),+-- * @n@ is not one of the restricted names (see 'RestrictedName')+--+-- >>> :kind! CanAdd "name" '["n1" ->> Int, "n2" ->> String]+-- CanAdd "name" '["n1" ->> Int, "n2" ->> String] :: Constraint+-- = (GHC.TypeLits.KnownSymbol "name", () :: Constraint,+-- () :: Constraint)+--+-- >>> :kind! CanAdd "n1" '["n1" ->> Int, "n2" ->> String]+-- CanAdd "n1" '["n1" ->> Int, "n2" ->> String] :: Constraint+-- = (GHC.TypeLits.KnownSymbol "n1", () :: Constraint,+-- (TypeError ...))+type family CanAdd n ns :: Constraint where+ CanAdd n ns = (KnownSymbol n, DisallowRestrictedName (RestrictedName n) n, RequireUniqueName (UniqueName n ns) n)++type family UniqueName (name :: Symbol) (ts :: [Claim Type]) :: Bool where+ UniqueName _ '[] = 'True+ UniqueName n (n ->> _ : _) = 'False+ UniqueName n (_ : rest) = UniqueName n rest++type family RequireUniqueName (isUnique :: Bool) (name :: Symbol) :: Constraint where+ RequireUniqueName 'True _ = ()+ RequireUniqueName 'False n = TypeError ('Text "Claim " ':<>: 'ShowType n ':<>: 'Text " is not unique in this claim set")++type family RestrictedName (name :: Symbol) :: Bool where+ RestrictedName "iss" = 'True+ RestrictedName "sub" = 'True+ RestrictedName "aud" = 'True+ RestrictedName "exp" = 'True+ RestrictedName "nbf" = 'True+ RestrictedName "iat" = 'True+ RestrictedName "jti" = 'True+ RestrictedName _ = 'False++type family DisallowRestrictedName (isRestricted :: Bool) (name :: Symbol) :: Constraint where+ DisallowRestrictedName 'False _ = ()+ DisallowRestrictedName 'True n = TypeError+ ( 'ShowType n+ ':<>:+ 'Text " is the name of the registered claim (it is exposed as a field that must be set directly or use JwtBuilder)"+ )++unsafeLookup :: String -> PrivateClaims ts ns -> p+unsafeLookup claimName pc = unAny $ unsafeClaimsMap pc ! claimName+ where unAny (Any a) = unsafeCoerce a++-- | Look up the claim value associated with @name@.+--+-- Value can be retrieved if proven to exists in the container.+-- Otherwise it is a compile-time error (see 'CanGet' constraint)+-- +-- With @-XOverloadedLabels@+--+-- >>> getClaim #bool $ #string ->> "Value of claim" .: #bool ->> False .: nullClaims+-- False+getClaim+ :: forall name ts ns+ . CanGet name ts+ => ClaimName name+ -> PrivateClaims ts ns+ -> LookupClaimType name ts+getClaim _ = unsafeLookup name where name = symbolVal (Proxy :: Proxy name)+{-# INLINE getClaim #-}++-- | Alias for 'getClaim' (container goes first)+--+-- With @-XOverloadedLabels@+--+-- >>> (#string ->> "Value of claim" .: #bool ->> False .: nullClaims) .! #bool+-- False+(.!)+ :: forall name ts ns+ . CanGet name ts+ => PrivateClaims ts ns+ -> ClaimName name+ -> LookupClaimType name ts+pc .! name = getClaim name pc++-- | Constraint specifying when a claim named @n@ can be looked up in the list of claims @ns@+--+-- Satisfied iff @ns@ contains a claim named @n@ and @n@ is a type-level literal+--+-- >>> :kind! CanGet "n1" '["n1" ->> Int, "n2" ->> String]+-- CanGet "n1" '["n1" ->> Int, "n2" ->> String] :: Constraint+-- = (GHC.TypeLits.KnownSymbol "n1", () :: Constraint)+--+-- >>> :kind! CanGet "n" '["n1" ->> Int, "n2" ->> String]+-- CanGet "n" '["n1" ->> Int, "n2" ->> String] :: Constraint+-- = (GHC.TypeLits.KnownSymbol "n", (TypeError ...))+type family CanGet n ns :: Constraint where+ CanGet n ns = (KnownSymbol n, RequireExists (NameExists n ns) n)++-- | Looks up the type associated with @name@ in the @'[n1 t'->>' a, n2 t'->>' b, ...]@ pairs list. Gets stuck if @name@ is not in @ts@+--+-- >>> :kind! LookupClaimType "n1" '["n1" ->> Int, "n2" ->> String]+-- LookupClaimType "n1" '["n1" ->> Int, "n2" ->> String] :: *+-- = Int+type family LookupClaimType (name :: Symbol) (ts :: [Claim Type]) :: Type where+ LookupClaimType n (n ->> a : _) = a+ LookupClaimType n (_ : rest) = LookupClaimType n rest++type family NameExists (name :: Symbol) (ts :: [Claim Type]) :: Bool where+ NameExists _ '[] = 'False+ NameExists n (n ->> _ : _) = 'True+ NameExists n (_ : rest ) = NameExists n rest++type family RequireExists (exists :: Bool) (name :: Symbol) :: Constraint where+ RequireExists 'True _ = ()+ RequireExists 'False n = TypeError ('Text "Claim " ':<>: 'ShowType n ':<>: 'Text " does not exist in this claim set")++getTail :: PrivateClaims (name ->> a : tl) ns -> PrivateClaims tl ns+getTail = coerce++view :: forall name a tl ns . KnownSymbol name => PrivateClaims (name ->> a : tl) ns -> (a, PrivateClaims tl ns)+view pc = (a, tl)+ where+ a = pc .! (ClaimName @name)+ tl = getTail pc++-- | Extract values from the container in the order in which they appear in the claim list+pattern (:<) :: KnownSymbol name => a -> PrivateClaims tl ns -> PrivateClaims (name ->> a : tl) ns+pattern head :< tail <- (view -> (head, tail))++{-# COMPLETE (:<) :: PrivateClaims #-}++-- | Convert to private claims with some namespace+withNs+ :: ToPrivateClaims a => Ns ns -> a -> PrivateClaims (Claims a) ( 'SomeNs ns)+withNs _ = coerce . toPrivateClaims++-- | Set namespace+someNs :: Ns ns -> PrivateClaims ts 'NoNs -> PrivateClaims ts ( 'SomeNs ns)+someNs _ = coerce++-- | Unset namespace+noNs :: PrivateClaims ts any -> PrivateClaims ts 'NoNs+noNs = coerce++getHead+ :: forall name a tl ns . (KnownSymbol name, KnownNamespace ns) => PrivateClaims (name ->> a : tl) ns -> (String, a)+getHead pc = (fullClaimName (Proxy :: Proxy ns) claimName, claimValue)+ where+ claimName = symbolVal (Proxy :: Proxy name)+ claimValue = unsafeLookup claimName pc+{-# INLINE getHead #-}++instance (ts ~ Empty, ns ~ 'NoNs) => Default (PrivateClaims ts ns) where+ def = nullClaims++instance Encode (PrivateClaims Empty ns) where+ encode _ = nullEncode++instance+ ( ClaimEncoder a+ , KnownSymbol name+ , KnownNamespace ns+ , Encode (PrivateClaims tl ns)+ )+ => Encode (PrivateClaims (name ->> a : tl) ns) where+ encode pc jwt = encodeClaim claimName a jwt >> encode (getTail pc) jwt+ where (claimName, a) = getHead pc++instance Decode (PrivateClaims Empty ns) where+ decode = const $ return $ coerce nullClaims++instance+ ( ty ~ DecodeAuxDef a+ , DecodeAux ty ns name a+ , CanAdd name tl+ , Decode (PrivateClaims tl ns)+ )+ => Decode (PrivateClaims (name ->> a : tl) ns) where+ decode jwt = liftA2 (.:) decodeHead decodeTail+ where+ decodeHead = decodeAux @ty @ns @name jwt+ decodeTail = decode jwt++data DecodeTy = Opt | Req | Mono++class DecodeAux (ty :: DecodeTy) (ns :: Namespace) (name :: Symbol) (a :: Type) where+ decodeAux :: JwtT -> JwtIO (ClaimWitness name a)++instance+ ( b ~ Maybe a+ , Decodable a+ , KnownNamespace ns+ , KnownSymbol name+ )+ => DecodeAux 'Opt ns name b where+ decodeAux = coerce . getOptional . decodeClaimProxied (fullClaimName' @ns @name) (Proxy :: Proxy a)++instance+ ( Decodable a+ , KnownNamespace ns+ , KnownSymbol name+ )+ => DecodeAux 'Req ns name a where+ decodeAux = coerce . decodeClaimOrThrow (fullClaimName' @ns @name) (Proxy :: Proxy a)++instance+ ( b ~ [a]+ , Decodable [a]+ , KnownNamespace ns+ , KnownSymbol name+ )+ => DecodeAux 'Mono ns name b where+ decodeAux = coerce . getOrEmpty . decodeClaimProxied (fullClaimName' @ns @name) (Proxy :: Proxy b)++type family DecodeAuxDef a :: DecodeTy where+ DecodeAuxDef (Maybe b) = 'Opt+ DecodeAuxDef String = 'Req+ DecodeAuxDef [b] = 'Mono+ DecodeAuxDef _ = 'Req++type family Showable pc :: Constraint where+ Showable (PrivateClaims (name ->> a : tl) ns) = (KnownSymbol name, KnownNamespace ns, Show a, ShowL (PrivateClaims tl ns))++instance Show (PrivateClaims Empty ns) where+ show _ = "()"++instance Showable (PrivateClaims (name ->> a : tl) ns) => Show (PrivateClaims (name ->> a : tl) ns) where+ showsPrec _ pc =+ showChar '(' . showHead pc . showl (getTail pc) . showChar ')'++showHead+ :: (KnownSymbol name, KnownNamespace ns, Show a) => PrivateClaims ((name ->> a) : tl) ns -> ShowS+showHead pc =+ showChar '#' . showString claimName . showString " ->> " . showsPrec 6 a+ where (claimName, a) = getHead pc++class ShowL a where+ showl :: a -> ShowS++instance ShowL (PrivateClaims Empty ns) where+ showl _ = id++instance Showable (PrivateClaims (name ->> a : tl) ns) => ShowL (PrivateClaims (name ->> a : tl) ns) where+ showl pc = showCommaSpace . showHead pc . showl (getTail pc)++instance Eq (PrivateClaims Empty any) where+ _ == _ = True++instance (Eq a, KnownSymbol name, Eq (PrivateClaims tl ns)) => Eq (PrivateClaims (name ->> a : tl) ns) where+ pc1 == pc2 = pc1 .! (ClaimName @name) == pc2 .! (ClaimName @name) && getTail pc1 == getTail pc2++-- | Class of types that can be converted to 'PrivateClaims'+class ToPrivateClaims a where+ type Claims a :: [Claim Type]+ type Claims a = ClaimsFromRecord (Rep a)++ type OutNs a :: Namespace+ type OutNs a = 'NoNs++ -- | Convert to claims+ toPrivateClaims :: a -> PrivateClaims (Claims a) (OutNs a)++ default toPrivateClaims+ :: ( Generic a+ , RecordToPrivateClaims (Rep a)+ , Claims a ~ ClaimsFromRecord (Rep a)+ , OutNs a ~ 'NoNs+ )+ => a -> PrivateClaims (Claims a) (OutNs a)+ toPrivateClaims = genericToPrivateClaims . from++-- | Class of types that can be constructed from @PrivateClaims@+class FromPrivateClaims a where+ -- | Convert from claims+ fromPrivateClaims :: ts ~ Claims a => PrivateClaims ts ns -> a++ default fromPrivateClaims + :: ( Generic a+ , RecordFromPrivateClaims (Rep a)+ , ts ~ ClaimsFromRecord(Rep a)+ ) + => PrivateClaims ts ns -> a+ fromPrivateClaims = to . genericFromPrivateClaims++class RecordToPrivateClaims g where+ type ClaimsFromRecord g :: [Claim Type]++ genericToPrivateClaims :: g p -> PrivateClaims (ClaimsFromRecord g) 'NoNs++class RecordFromPrivateClaims g where+ genericFromPrivateClaims :: PrivateClaims (ClaimsFromRecord g) ns -> g p++instance RecordToPrivateClaims c => RecordToPrivateClaims (D1 m c) where+ type ClaimsFromRecord (D1 m c) = ClaimsFromRecord c++ genericToPrivateClaims (M1 c) = genericToPrivateClaims c++instance RecordFromPrivateClaims c => RecordFromPrivateClaims (D1 m c) where+ genericFromPrivateClaims = M1 . genericFromPrivateClaims++instance RecordToPrivateClaims f => RecordToPrivateClaims (C1 m f) where+ type ClaimsFromRecord (C1 m f) = ClaimsFromRecord f++ genericToPrivateClaims (M1 f) = genericToPrivateClaims f++instance RecordFromPrivateClaims f => RecordFromPrivateClaims (C1 m f) where+ genericFromPrivateClaims = M1 . genericFromPrivateClaims ++type family (+++) (lhs :: [k]) (rhs :: [k]) :: [k] where+ '[] +++ rhs = rhs+ (a : rest) +++ rhs = a : (rest +++ rhs)++instance (RecordToPrivateClaims s1, RecordToPrivateClaims s2) => RecordToPrivateClaims (s1 :*: s2) where+ type ClaimsFromRecord (s1 :*: s2) = ClaimsFromRecord s1 +++ ClaimsFromRecord s2++ genericToPrivateClaims (s1 :*: s2) = PrivateClaims $ HashMap.union store1 store2+ where+ store1 = unsafeClaimsMap $ genericToPrivateClaims s1+ store2 = unsafeClaimsMap $ genericToPrivateClaims s2++instance (RecordFromPrivateClaims s1, RecordFromPrivateClaims s2) => RecordFromPrivateClaims (s1 :*: s2) where+ genericFromPrivateClaims pc = s1 :*: s2 where+ s1 = genericFromPrivateClaims (coerce pc)+ s2 = genericFromPrivateClaims (coerce pc)++type family HasSelectorName (m :: Meta) :: Constraint where+ HasSelectorName ('MetaSel ('Just s) _ _ _) = ()+ HasSelectorName _ = TypeError+ ( 'Text "Only records with named fields can be converted to PrivateClaims. For instance, "+ ':$$:+ 'Text "data Good = MkGood { a :: Int, b :: String } is ok, but "+ ':$$:+ 'Text "data Bad = MkBad Int String is not"+ )++type family SelectorName (m :: Meta) :: Symbol where+ SelectorName ('MetaSel ('Just s) _ _ _) = s++instance (Selector s, HasSelectorName s) => RecordToPrivateClaims (S1 s (Rec0 a)) where+ type ClaimsFromRecord (S1 s (Rec0 a)) = '[SelectorName s ->> a]++ genericToPrivateClaims (M1 (K1 a)) = PrivateClaims $ HashMap.singleton fieldName $ Any a+ where+ fieldName = selNameProxied (Proxy :: Proxy (S1 s (Rec0 a) p))++instance (Selector s, HasSelectorName s) => RecordFromPrivateClaims (S1 s (Rec0 a)) where+ genericFromPrivateClaims = M1 . K1 . unsafeLookup fieldName+ where+ fieldName = selNameProxied (Proxy :: Proxy (S1 s (Rec0 a) p))++instance+ ( TypeError+ ( 'Text "Only records with named fields can be converted to PrivateClaims. For instance, "+ ':$$:+ 'Text "data Good = MkGood { a :: Int, b :: String } is ok, but "+ ':$$:+ 'Text "data Bad = Bad1 Int | Bad2 String is not"+ )+ )+ => RecordToPrivateClaims (any :+: thing) where+ genericToPrivateClaims = error "impossible"++instance+ ( TypeError+ ( 'Text "Only records with named fields can be constructed from PrivateClaims. For instance, "+ ':$$:+ 'Text "data Good = MkGood { a :: Int, b :: String } is ok, but "+ ':$$:+ 'Text "data Bad = Bad1 Int | Bad2 String is not"+ )+ )+ => RecordFromPrivateClaims (any :+: thing) where+ genericFromPrivateClaims = error "impossible"++instance ToPrivateClaims () where+ type Claims () = Empty++ toPrivateClaims _ = nullClaims++instance CanAdd n '[] => ToPrivateClaims (ClaimWitness n a) where+ type Claims (ClaimWitness n a) = '[n ->> a]+ toPrivateClaims (Witness a) = addClaim ClaimName a nullClaims++instance (CanAdd n2 '[], CanAdd n1 '[n2 ->> b]) => ToPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b) where+ type Claims (ClaimWitness n1 a, ClaimWitness n2 b) = '[n1 ->> a, n2 ->> b]+ toPrivateClaims (Witness a, Witness b) =+ addClaim ClaimName a $ addClaim ClaimName b nullClaims++instance (KnownSymbol n1, KnownSymbol n2) => FromPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b) where+ fromPrivateClaims (a :< b :< _) = (Witness a, Witness b)++instance+ ( CanAdd n1 '[n2 ->> b, n3 ->> c]+ , CanAdd n2 '[n3 ->> c]+ , CanAdd n3 '[]+ )+ => ToPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c) where+ type Claims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c) = '[n1 ->> a, n2 ->> b, n3 ->> c]+ toPrivateClaims (Witness a, Witness b, Witness c) =+ addClaim ClaimName a $+ addClaim ClaimName b $+ addClaim ClaimName c nullClaims++instance + ( KnownSymbol n1+ , KnownSymbol n2+ , KnownSymbol n3+ ) => FromPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c) where+ fromPrivateClaims (a :< b :< c :< _) = (Witness a, Witness b ,Witness c)++instance+ ( CanAdd n1 '[n2 ->> b, n3 ->> c, n4 ->> d]+ , CanAdd n2 '[n3 ->> c, n4 ->> d]+ , CanAdd n3 '[n4 ->> d]+ , CanAdd n4 '[]+ )+ => ToPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c, ClaimWitness n4 d) where+ type Claims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c, ClaimWitness n4 d) = '[n1 ->> a, n2 ->> b, n3 ->> c, n4 ->> d]+ toPrivateClaims (Witness a, Witness b, Witness c, Witness d) =+ addClaim ClaimName a $+ addClaim ClaimName b $+ addClaim ClaimName c $+ addClaim ClaimName d nullClaims++instance + ( KnownSymbol n1+ , KnownSymbol n2+ , KnownSymbol n3+ , KnownSymbol n4+ ) + => FromPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c, ClaimWitness n4 d) where+ fromPrivateClaims (a :< b :< c :< d :< _) =+ (Witness a, Witness b, Witness c, Witness d)++instance+ ( CanAdd n1 '[n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e]+ , CanAdd n2 '[n3 ->> c, n4 ->> d, n5 ->> e]+ , CanAdd n3 '[n4 ->> d, n5 ->> e]+ , CanAdd n4 '[n5 ->> e]+ , CanAdd n5 '[]+ )+ => ToPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c, ClaimWitness n4 d, ClaimWitness n5 e) where+ type Claims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e) = '[n1 ->> a, n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e]++ toPrivateClaims (Witness a, Witness b, Witness c, Witness d, Witness e) =+ addClaim ClaimName a $+ addClaim ClaimName b $+ addClaim ClaimName c $+ addClaim ClaimName d $+ addClaim ClaimName e nullClaims++instance+ ( KnownSymbol n1+ , KnownSymbol n2+ , KnownSymbol n3+ , KnownSymbol n4+ , KnownSymbol n5+ )+ => FromPrivateClaims (ClaimWitness n1 a, ClaimWitness n2 b, ClaimWitness n3 c, ClaimWitness n4 d, ClaimWitness n5 e) where+ fromPrivateClaims (a :< b :< c :< d :< e :< _) = (Witness a, Witness b, Witness c, Witness d, Witness e)++instance+ ( CanAdd n1 '[n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f]+ , CanAdd n2 '[n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f]+ , CanAdd n3 '[n4 ->> d, n5 ->> e, n6 ->> f]+ , CanAdd n4 '[n5 ->> e, n6 ->> f]+ , CanAdd n5 '[n6 ->> f]+ , CanAdd n6 '[]+ )+ => ToPrivateClaims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f) where+ type Claims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f) = '[n1 ->> a, n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f]++ toPrivateClaims (Witness a, Witness b, Witness c, Witness d, Witness e, Witness f) =+ addClaim ClaimName a $+ addClaim ClaimName b $+ addClaim ClaimName c $+ addClaim ClaimName d $+ addClaim ClaimName e $+ addClaim ClaimName f nullClaims++instance + ( KnownSymbol n1+ , KnownSymbol n2+ , KnownSymbol n3+ , KnownSymbol n4+ , KnownSymbol n5+ , KnownSymbol n6+ )+ => FromPrivateClaims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f) where+ fromPrivateClaims (a :< b :< c :< d :< e :< f :< _) =+ (Witness a, Witness b, Witness c, Witness d, Witness e, Witness f)++instance+ ( CanAdd n1 '[n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f, n7 ->> g]+ , CanAdd n2 '[n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f, n7 ->> g]+ , CanAdd n3 '[n4 ->> d, n5 ->> e, n6 ->> f, n7 ->> g]+ , CanAdd n4 '[n5 ->> e, n6 ->> f, n7 ->> g]+ , CanAdd n5 '[n6 ->> f, n7 ->> g]+ , CanAdd n6 '[n7 ->> g]+ , CanAdd n7 '[]+ )+ => ToPrivateClaims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f+ , ClaimWitness n7 g) where+ type Claims+ ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f+ , ClaimWitness n7 g) = '[n1 ->> a, n2 ->> b, n3 ->> c, n4 ->> d, n5 ->> e, n6 ->> f, n7 ->> g]++ toPrivateClaims (Witness a, Witness b, Witness c, Witness d, Witness e, Witness f, Witness g) =+ addClaim ClaimName a $+ addClaim ClaimName b $+ addClaim ClaimName c $+ addClaim ClaimName d $+ addClaim ClaimName e $+ addClaim ClaimName f $+ addClaim ClaimName g nullClaims++instance+ ( KnownSymbol n1+ , KnownSymbol n2+ , KnownSymbol n3+ , KnownSymbol n4+ , KnownSymbol n5+ , KnownSymbol n6+ , KnownSymbol n7+ ) + => FromPrivateClaims + ( ClaimWitness n1 a+ , ClaimWitness n2 b+ , ClaimWitness n3 c+ , ClaimWitness n4 d+ , ClaimWitness n5 e+ , ClaimWitness n6 f+ , ClaimWitness n7 g) where+ fromPrivateClaims (a :< b :< c :< d :< e :< f :< g :< _) =+ (Witness a, Witness b, Witness c, Witness d, Witness e, Witness f, Witness g)+ ++instance ToPrivateClaims (PrivateClaims ts ns) where+ type Claims (PrivateClaims ts ns) = ts+ type OutNs (PrivateClaims ts ns) = ns+ toPrivateClaims = id+
+ src/Libjwt/RegisteredClaims.hs view
@@ -0,0 +1,136 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Representation of registered claims+module Libjwt.RegisteredClaims+ ( Iss(..)+ , Sub(..)+ , Aud(..)+ , Exp(..)+ , Nbf(..)+ , Iat(..)+ , Jti(..)+ )+where++import Libjwt.NumericDate+import Libjwt.Encoding+import Libjwt.Decoding++import Control.Applicative ( (<|>) )+import Data.Coerce ( coerce )++import Data.Default++import Data.Proxy++import Data.UUID ( UUID )++-- | /iss/ (Issuer) claim+newtype Iss = Iss (Maybe String)+ deriving stock (Show, Eq)++-- | /sub/ (Subject) claim+newtype Sub = Sub (Maybe String)+ deriving stock (Show, Eq)++-- | /aud/ (Audience) claim+newtype Aud = Aud [String]+ deriving stock (Show, Eq)+ deriving newtype (Semigroup, Monoid)++-- | /exp/ (Expiration Time) claim+newtype Exp = Exp (Maybe NumericDate)+ deriving stock (Show, Eq)++instance Ord Exp where+ Exp _ <= Exp Nothing = True+ Exp Nothing <= Exp _ = False+ Exp (Just a) <= Exp (Just b) = a <= b++-- | /nbf/ (Not Before) claim+newtype Nbf = Nbf (Maybe NumericDate)+ deriving stock (Show, Eq, Ord)++-- | /iat/ (Issued At) claim+newtype Iat = Iat (Maybe NumericDate)+ deriving stock (Show, Eq, Ord)++-- | /jti/ (JWT ID) claim+newtype Jti = Jti (Maybe UUID)+ deriving stock (Show, Eq)++instance Encode Iss where+ encode (Iss iss) = encodeClaim "iss" iss++instance Decode Iss where+ decode =+ coerce . getOptional . decodeClaimProxied "iss" (Proxy :: Proxy String)++instance Encode Sub where+ encode (Sub sub) = encodeClaim "sub" sub++instance Decode Sub where+ decode =+ coerce . getOptional . decodeClaimProxied "sub" (Proxy :: Proxy String)++instance Encode Aud where+ encode (Aud aud) = encodeClaim "aud" aud++instance Decode Aud where+ decode jwt = coerce $ getOrEmpty $ tryDecodeList <|> pure <$> tryDecodeSingle+ where+ tryDecodeList = decodeClaimProxied "aud" (Proxy :: Proxy [String]) jwt+ tryDecodeSingle = decodeClaimProxied "aud" (Proxy :: Proxy String) jwt++instance Encode Exp where+ encode (Exp exp) = encodeClaim "exp" exp++instance Decode Exp where+ decode =+ coerce . getOptional . decodeClaimProxied "exp" (Proxy :: Proxy NumericDate)++instance Encode Nbf where+ encode (Nbf nbf) = encodeClaim "nbf" nbf++instance Decode Nbf where+ decode =+ coerce . getOptional . decodeClaimProxied "nbf" (Proxy :: Proxy NumericDate)++instance Encode Iat where+ encode (Iat iat) = encodeClaim "iat" iat++instance Decode Iat where+ decode =+ coerce . getOptional . decodeClaimProxied "iat" (Proxy :: Proxy NumericDate)++instance Encode Jti where+ encode (Jti jti) = encodeClaim "jti" jti++instance Decode Jti where+ decode =+ coerce . getOptional . decodeClaimProxied "jti" (Proxy :: Proxy UUID)++instance Default Iss where+ def = Iss Nothing++instance Default Sub where+ def = Sub Nothing++instance Default Exp where+ def = Exp Nothing++instance Default Nbf where+ def = Nbf Nothing++instance Default Iat where+ def = Iat Nothing++instance Default Jti where+ def = Jti Nothing
+ src/Web/Libjwt.hs view
@@ -0,0 +1,301 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_HADDOCK not-home #-}++{- |+Copyright: (c) 2020 Marcin Rzeźnicki+SPDX-License-Identifier: MPL-2.0+Maintainer: Marcin Rzeźnicki <marcin.rzeznicki@gmail.com>++The prelude for the library.++= Creating a payload++'Payload' consists of:++ * registered claims: 'Iss', 'Sub', 'Aud', 'Jti', 'Exp', 'Nbf', 'Iat'+ * private claims++Private claims can be created from:++ * "named" tuples (tuples with elements created via v'->>')+ * records that are instances of 'ToPrivateClaims'++Public claims can be created:++ * directly, by setting fields of 'Payload' record+ * via 'JwtBuilder'++Payload keeps track of names and types of private claims as a part of its type. +In all the examples below the type is: ++@+'Payload' '["user_name" t'->>' String, "is_root" t'->>' Bool, "user_id" t'->>' Int] ''NoNs'+@++== From "named" tuples++@+{-# LANGUAGE OverloadedLabels #-}+mkPayload currentTime =+ let now = 'fromUTC' currentTime+ in def+ { iss = 'Iss' (Just "myApp")+ , aud = 'Aud' ["https://myApp.com"]+ , iat = 'Iat' (Just now)+ , exp = 'Exp' (Just $ now `plusSeconds` 300)+ , privateClaims = 'toPrivateClaims'+ ( #user_name v'->>' "John Doe"+ , #is_root v'->>' False+ , #user_id v'->>' (12345 :: Int)+ )+ }+@++== From records++@+data UserClaims = UserClaims { user_name :: String+ , is_root :: Bool+ , user_id :: Int+ }+ deriving stock (Eq, Show, Generic)++instance 'ToPrivateClaims' UserClaims++mkPayload currentTime =+ let now = 'fromUTC' currentTime+ in def+ { iss = Iss (Just "myApp")+ , aud = Aud ["https://myApp.com"]+ , iat = Iat (Just now)+ , exp = Exp (Just $ now `plusSeconds` 300)+ , privateClaims = 'toPrivateClaims'+ UserClaims { user_name = "John Doe"+ , is_root = False+ , user_id = 12345+ }+ }+@++== Using JwtBuilder++If you prefer more "fluent" style, you might want to use 'jwtPayload' function++@+mkPayload = 'jwtPayload'+ ('withIssuer' "myApp" <> 'withRecipient' "https://myApp.com" <> 'setTtl' 300)+ UserClaims { user_name = "John Doe"+ , is_root = False+ , user_id = 12345+ }+@++For the list of available "builders", please see the docs of "Libjwt.Payload" module.+This methods relies on "Control.Monad.MonadTime" to get the current time.++= Namespaces++To ensure that private do not collide with claims from other resources, it is recommended to give them globally unique names . +This is often done through namespacing, i.e. prefixing the names with the URI of a resource you control. +This is handled entirely at the type-level. ++As you may have noticed, 'Payload' types has a component of kind 'Namespace'. +It tracks the namespace assigned to private claims within the payload. If you change the last example to:++@+{-# LANGUAGE DataKinds #-}++mkPayload' =+ jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ $ 'withNs'+ ('Ns' @"https://myApp.com")+ UserClaims + { user_name = "John Doe"+ , is_root = False+ , user_id = 12345+ }+@++, you'll notice that the type has changed to accomodate the namespace, becoming ++@+'Payload' '["user_name" t'->>' String, "is_root" t'->>' Bool, "user_id" t'->>' Int] (''SomeNs' "https://myApp.com")+@++Consequently, in the generated token /"user_id"/ becomes /"https://myApp.com/user_id"/ etc.++= Signing++Signing is the process of transforming the 'Jwt' structure with 'Payload' and 'Header' into a token with a cryptographic signature that can be sent over-the-wire.++== Supported algorithms++To sign a token, you need to choose the algorithm. +++----------+---------------------------------------++|Algorithm | Description | ++==========+=======================================++|'HS256' | HMAC with SHA-256 |++----------+---------------------------------------++|'HS384' | HMAC with SHA-384 |++----------+---------------------------------------++|'HS512' | HMAC with SHA-512 |++----------+---------------------------------------++|'RS256' | RSASSA-PKCS1-v1_5 with SHA-256 |++----------+---------------------------------------++|'RS384' | RSASSA-PKCS1-v1_5 with SHA-384 |++----------+---------------------------------------++|'RS512' | RSASSA-PKCS1-v1_5 with SHA-512 |++----------+---------------------------------------++|'ES256' | ECDSA with curve P-256 and SHA-256 |++----------+---------------------------------------++|'ES384' | ECDSA with curve P-384 and SHA-384 |++----------+---------------------------------------++|'ES512' | ECDSA with curve P-521 and SHA-512 |++----------+---------------------------------------+++The complete example: ++@+{-# LANGUAGE OverloadedStrings #-}++hmac512 :: 'Alg'+hmac512 =+ 'HS512'+ "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\\+ \\YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\\+ \\Y2IwMDZhYWY1MjY1OTQgIC0K"++token :: IO ByteString+token = fmap ('getToken' . 'sign' hmac512) $ jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ UserClaims { user_name = "John Doe"+ , is_root = False+ , user_id = 12345+ }+@++= Decoding++Decoding is a 2-step process. /Step 1/ is to take the token, validate its signature and check its structural correctness +(is it valid JSON, is it a valid JWT object, does it have all the claims?). If any of these tests fail,+we don't have a valid token and an exception is thrown (see 'SomeDecodeException'). In /step 2/, the decoded token is validated -+has it expired? does it have the right issuer? etc. The resulting value is of type @'ValidationNEL' 'ValidationFailure' ('Validated' MyJwtType)@++It is __important__ to only work with valid tokens (if a token is not validated, it may be addressed to someone else or may be 2 weeks old),+so the rest of your program should only accept @'Validated' MyJwt@, not @'Decoded' MyJwt@, which is the result of step 1.++@+type MyJwt+ = 'Jwt'+ '["userId" t'->>' UUID, "userName" t'->>' Text, "isRoot" t'->>' Bool, "createdAt" t'->>' UTCTime, "accounts" t'->>' NonEmpty UUID]+ ''NoNs'++decodeAndValidate :: IO ('ValidationNEL' 'ValidationFailure' ('Validated' MyJwt))+decodeAndValidate = 'jwtFromByteString' settings mempty hmac512 =<< token+ where+ settings = 'Settings' { leeway = 5, appName = Just "https://myApp.com" }+@++By default only validations mandated by the RFC are performed:++ * check /exp/ claim against the current time,+ * check /nbf/ claim against the current time,+ * check /aud/ claim against 'appName'++You can add your own validations:++@+decodeAndValidate :: IO ('ValidationNEL' 'ValidationFailure' ('Validated' MyJwt))+decodeAndValidate = 'jwtFromByteString' settings ('checkIssuer' "myApp" <> 'checkClaim' not #is_root) hmac512 =<< token+ where+ settings = 'Settings' { leeway = 5, appName = Just "https://myApp.com" }+@++If for some reason, you do not want to validate a token, but only decode it, you can use 'decodeByteString'++= Types supported in claims++Currently, these types are supported:++ * ByteString+ * String+ * Text+ * 'ASCII'+ * 'Libjwt.JsonByteString'+ * Bool+ * 'NumericDate'+ * 'Flag'+ * Int+ * UUID+ * UTCTime, ZonedTime, LocalTime, Day+ * Maybes of the above type+ * lists of the above types and lists of tuples created from them+ * NonEmpty lists of the above types+ +If you want to support a different type, check out "Libjwt.Classes".+If you want to work with aeson, check "Libjwt.JsonByteString"++-}++module Web.Libjwt+ ( module Libjwt.Jwt+ , module Libjwt.Exceptions+ , module Libjwt.Header+ , module Libjwt.Keys+ , module Libjwt.Payload+ , module Libjwt.RegisteredClaims+ , module Libjwt.PrivateClaims+ , module Libjwt.JwtValidation+ , module Libjwt.NumericDate+ , module Libjwt.ASCII+ , module Libjwt.Flag+ , module Libjwt.Encoding+ , module Libjwt.Decoding+ )+where++import Libjwt.ASCII ( ASCII(..) )+import Libjwt.Decoding ( Decode )+import Libjwt.Encoding ( Encode )+import Libjwt.Exceptions+import Libjwt.Flag ( Flag(..)+ , AFlag(..)+ )+import Libjwt.Header+import Libjwt.Jwt ( Jwt(..)+ , sign+ , signJwt+ , Encoded+ , getToken+ , jwtFromString+ , jwtFromByteString+ , decodeString+ , decodeByteString+ , Decoded+ , getDecoded+ , validateJwt+ , Validated+ , getValid+ )+import Libjwt.JwtValidation hiding ( runValidation+ , Valid+ , Check+ , invalid+ , valid+ , validation+ )+import Libjwt.Keys+import Libjwt.NumericDate ( NumericDate(..)+ , fromUTC+ , fromPOSIX+ , plusSeconds+ )+import Libjwt.Payload+import Libjwt.PrivateClaims+import Libjwt.RegisteredClaims+
+ src/Web/Libjwt/Tutorial.hs view
@@ -0,0 +1,131 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# OPTIONS_GHC -Wno-unused-binds -Wno-missing-signatures #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Web.Libjwt.Tutorial+ ()+where++import Web.Libjwt++import Control.Arrow ( left )+import Control.Exception ( catch+ , displayException+ )+import Data.ByteString ( ByteString )+import Data.Default+import Data.Either.Validation ( validationToEither )+import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Text ( Text )+import Data.Time.Clock ( UTCTime )+import Data.UUID ( UUID )+import GHC.Generics++import Prelude hiding ( exp )+++data UserClaims = UserClaims { userId :: UUID+ , userName :: Text+ , isRoot :: Bool+ , createdAt :: UTCTime+ , accounts :: NonEmpty UUID+ }+ deriving stock (Eq, Show, Generic)++instance ToPrivateClaims UserClaims+instance FromPrivateClaims UserClaims++hmac512 :: Alg+hmac512 =+ HS512+ "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\+ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\+ \Y2IwMDZhYWY1MjY1OTQgIC0K"++mkPayload UserClaims {..} currentTime =+ let now = fromUTC currentTime+ in def+ { iss = Iss (Just "myApp")+ , aud = Aud ["https://myApp.com"]+ , iat = Iat (Just now)+ , exp = Exp (Just $ now `plusSeconds` 300)+ , privateClaims = toPrivateClaims+ ( #user_name ->> userName+ , #is_root ->> isRoot+ , #user_id ->> userId+ , #created ->> createdAt+ , #accounts ->> accounts+ )+ }++mkPayload' UserClaims {..} = jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ ( #user_name ->> userName+ , #is_root ->> isRoot+ , #user_id ->> userId+ , #created ->> createdAt+ , #accounts ->> accounts+ )++mkPayload'' = jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ UserClaims { userId = read "5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"+ , userName = "JohnDoe"+ , isRoot = False+ , createdAt = read "2020-07-31 11:45:00 UTC"+ , accounts = read "0bdf91cc-48bb-47f5-b633-920c34bd2352" :| []+ }++mkPayload''' =+ jwtPayload+ (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)+ $ withNs+ (Ns @"https://myApp.com")+ UserClaims+ { userId = read "5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"+ , userName = "JohnDoe"+ , isRoot = False+ , createdAt = read "2020-07-31 11:45:00 UTC"+ , accounts = read "0bdf91cc-48bb-47f5-b633-920c34bd2352" :| []+ }++token :: IO ByteString+token = getToken . sign hmac512 <$> mkPayload''++type MyJwt+ = Jwt+ '["userId" ->> UUID, "userName" ->> Text, "isRoot" ->> Bool, "createdAt" ->> UTCTime, "accounts" ->> NonEmpty UUID]+ 'NoNs++decodeDoNotUse :: IO (Decoded MyJwt)+decodeDoNotUse = decodeByteString hmac512 =<< token++decodeAndValidate :: IO (ValidationNEL ValidationFailure (Validated MyJwt))+decodeAndValidate = jwtFromByteString settings mempty hmac512 =<< token+ where settings = Settings { leeway = 5, appName = Just "https://myApp.com" }++decodeAndValidateFull :: IO (Either String UserClaims)+decodeAndValidateFull =+ ( left (("Token not valid: " ++) . show)+ . fmap toUserClaims+ . validationToEither+ <$> decodeAndValidate+ )+ `catch` onError+ where+ toUserClaims = fromPrivateClaims . privateClaims . payload . getValid+ onError (e :: SomeDecodeException) =+ return $ Left $ "Cannot decode token " ++ displayException e
+ src/cbits/HsJsonTokenizer.c view
@@ -0,0 +1,49 @@+#include "jsmn.h"++#include <stdlib.h>+#include <errno.h>++int tokenize_json(const char* js, size_t jslen, jsmntok_t** out) {+ int r;++ jsmn_parser parser;+ jsmntok_t* tokens;+ size_t tokcount = 16;++ jsmn_init(&parser);++ tokens = malloc(sizeof(jsmntok_t) * tokcount);+ if (tokens == NULL) {+ return -ENOMEM;+ }++again:+ r = jsmn_parse(&parser, js, jslen, tokens, tokcount);+ if (r >= 0) {+ jsmntok_t* guard;+ if (tokcount == r) {+ tokens = realloc(tokens, sizeof(jsmntok_t) * (tokcount + 1));+ if (tokens == NULL) {+ return -ENOMEM;+ }+ }+ guard = &tokens[r];+ guard->type = JSMN_UNDEFINED;+ guard->size = 0;++ *out = tokens;++ } else if (r == JSMN_ERROR_NOMEM) {+ tokcount = tokcount * 2;+ tokens = realloc(tokens, sizeof(jsmntok_t) * tokcount);+ if (tokens == NULL) {+ return -ENOMEM;+ }+ goto again;+ } else {+ free(tokens);+ r = -EINVAL;+ }++ return r;+}
+ src/cbits/jsmn/LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2010 Serge A. Zaitsev++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.+
+ src/cbits/jsmn/Makefile view
@@ -0,0 +1,36 @@+# You can put your build options here+-include config.mk++test: test_default test_strict test_links test_strict_links+test_default: test/tests.c jsmn.h+ $(CC) $(CFLAGS) $(LDFLAGS) $< -o test/$@+ ./test/$@+test_strict: test/tests.c jsmn.h+ $(CC) -DJSMN_STRICT=1 $(CFLAGS) $(LDFLAGS) $< -o test/$@+ ./test/$@+test_links: test/tests.c jsmn.h+ $(CC) -DJSMN_PARENT_LINKS=1 $(CFLAGS) $(LDFLAGS) $< -o test/$@+ ./test/$@+test_strict_links: test/tests.c jsmn.h+ $(CC) -DJSMN_STRICT=1 -DJSMN_PARENT_LINKS=1 $(CFLAGS) $(LDFLAGS) $< -o test/$@+ ./test/$@++simple_example: example/simple.c jsmn.h+ $(CC) $(LDFLAGS) $< -o $@++jsondump: example/jsondump.c jsmn.h+ $(CC) $(LDFLAGS) $< -o $@++fmt:+ clang-format -i jsmn.h test/*.[ch] example/*.[ch]++lint:+ clang-tidy jsmn.h --checks='*'++clean:+ rm -f *.o example/*.o+ rm -f simple_example+ rm -f jsondump++.PHONY: clean test+
+ src/cbits/jsmn/jsmn.h view
@@ -0,0 +1,471 @@+/*+ * MIT License+ *+ * Copyright (c) 2010 Serge Zaitsev+ *+ * 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.+ */+#ifndef JSMN_H+#define JSMN_H++#include <stddef.h>++#ifdef __cplusplus+extern "C" {+#endif++#ifdef JSMN_STATIC+#define JSMN_API static+#else+#define JSMN_API extern+#endif++/**+ * JSON type identifier. Basic types are:+ * o Object+ * o Array+ * o String+ * o Other primitive: number, boolean (true/false) or null+ */+typedef enum {+ JSMN_UNDEFINED = 0,+ JSMN_OBJECT = 1,+ JSMN_ARRAY = 2,+ JSMN_STRING = 3,+ JSMN_PRIMITIVE = 4+} jsmntype_t;++enum jsmnerr {+ /* Not enough tokens were provided */+ JSMN_ERROR_NOMEM = -1,+ /* Invalid character inside JSON string */+ JSMN_ERROR_INVAL = -2,+ /* The string is not a full JSON packet, more bytes expected */+ JSMN_ERROR_PART = -3+};++/**+ * JSON token description.+ * type type (object, array, string etc.)+ * start start position in JSON data string+ * end end position in JSON data string+ */+typedef struct jsmntok {+ jsmntype_t type;+ int start;+ int end;+ int size;+#ifdef JSMN_PARENT_LINKS+ int parent;+#endif+} jsmntok_t;++/**+ * JSON parser. Contains an array of token blocks available. Also stores+ * the string being parsed now and current position in that string.+ */+typedef struct jsmn_parser {+ unsigned int pos; /* offset in the JSON string */+ unsigned int toknext; /* next token to allocate */+ int toksuper; /* superior token node, e.g. parent object or array */+} jsmn_parser;++/**+ * Create JSON parser over an array of tokens+ */+JSMN_API void jsmn_init(jsmn_parser *parser);++/**+ * Run JSON parser. It parses a JSON data string into and array of tokens, each+ * describing+ * a single JSON object.+ */+JSMN_API int jsmn_parse(jsmn_parser *parser, const char *js, const size_t len,+ jsmntok_t *tokens, const unsigned int num_tokens);++#ifndef JSMN_HEADER+/**+ * Allocates a fresh unused token from the token pool.+ */+static jsmntok_t *jsmn_alloc_token(jsmn_parser *parser, jsmntok_t *tokens,+ const size_t num_tokens) {+ jsmntok_t *tok;+ if (parser->toknext >= num_tokens) {+ return NULL;+ }+ tok = &tokens[parser->toknext++];+ tok->start = tok->end = -1;+ tok->size = 0;+#ifdef JSMN_PARENT_LINKS+ tok->parent = -1;+#endif+ return tok;+}++/**+ * Fills token type and boundaries.+ */+static void jsmn_fill_token(jsmntok_t *token, const jsmntype_t type,+ const int start, const int end) {+ token->type = type;+ token->start = start;+ token->end = end;+ token->size = 0;+}++/**+ * Fills next available token with JSON primitive.+ */+static int jsmn_parse_primitive(jsmn_parser *parser, const char *js,+ const size_t len, jsmntok_t *tokens,+ const size_t num_tokens) {+ jsmntok_t *token;+ int start;++ start = parser->pos;++ for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) {+ switch (js[parser->pos]) {+#ifndef JSMN_STRICT+ /* In strict mode primitive must be followed by "," or "}" or "]" */+ case ':':+#endif+ case '\t':+ case '\r':+ case '\n':+ case ' ':+ case ',':+ case ']':+ case '}':+ goto found;+ default:+ /* to quiet a warning from gcc*/+ break;+ }+ if (js[parser->pos] < 32 || js[parser->pos] >= 127) {+ parser->pos = start;+ return JSMN_ERROR_INVAL;+ }+ }+#ifdef JSMN_STRICT+ /* In strict mode primitive must be followed by a comma/object/array */+ parser->pos = start;+ return JSMN_ERROR_PART;+#endif++found:+ if (tokens == NULL) {+ parser->pos--;+ return 0;+ }+ token = jsmn_alloc_token(parser, tokens, num_tokens);+ if (token == NULL) {+ parser->pos = start;+ return JSMN_ERROR_NOMEM;+ }+ jsmn_fill_token(token, JSMN_PRIMITIVE, start, parser->pos);+#ifdef JSMN_PARENT_LINKS+ token->parent = parser->toksuper;+#endif+ parser->pos--;+ return 0;+}++/**+ * Fills next token with JSON string.+ */+static int jsmn_parse_string(jsmn_parser *parser, const char *js,+ const size_t len, jsmntok_t *tokens,+ const size_t num_tokens) {+ jsmntok_t *token;++ int start = parser->pos;++ parser->pos++;++ /* Skip starting quote */+ for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) {+ char c = js[parser->pos];++ /* Quote: end of string */+ if (c == '\"') {+ if (tokens == NULL) {+ return 0;+ }+ token = jsmn_alloc_token(parser, tokens, num_tokens);+ if (token == NULL) {+ parser->pos = start;+ return JSMN_ERROR_NOMEM;+ }+ jsmn_fill_token(token, JSMN_STRING, start + 1, parser->pos);+#ifdef JSMN_PARENT_LINKS+ token->parent = parser->toksuper;+#endif+ return 0;+ }++ /* Backslash: Quoted symbol expected */+ if (c == '\\' && parser->pos + 1 < len) {+ int i;+ parser->pos++;+ switch (js[parser->pos]) {+ /* Allowed escaped symbols */+ case '\"':+ case '/':+ case '\\':+ case 'b':+ case 'f':+ case 'r':+ case 'n':+ case 't':+ break;+ /* Allows escaped symbol \uXXXX */+ case 'u':+ parser->pos++;+ for (i = 0; i < 4 && parser->pos < len && js[parser->pos] != '\0';+ i++) {+ /* If it isn't a hex character we have an error */+ if (!((js[parser->pos] >= 48 && js[parser->pos] <= 57) || /* 0-9 */+ (js[parser->pos] >= 65 && js[parser->pos] <= 70) || /* A-F */+ (js[parser->pos] >= 97 && js[parser->pos] <= 102))) { /* a-f */+ parser->pos = start;+ return JSMN_ERROR_INVAL;+ }+ parser->pos++;+ }+ parser->pos--;+ break;+ /* Unexpected symbol */+ default:+ parser->pos = start;+ return JSMN_ERROR_INVAL;+ }+ }+ }+ parser->pos = start;+ return JSMN_ERROR_PART;+}++/**+ * Parse JSON string and fill tokens.+ */+JSMN_API int jsmn_parse(jsmn_parser *parser, const char *js, const size_t len,+ jsmntok_t *tokens, const unsigned int num_tokens) {+ int r;+ int i;+ jsmntok_t *token;+ int count = parser->toknext;++ for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) {+ char c;+ jsmntype_t type;++ c = js[parser->pos];+ switch (c) {+ case '{':+ case '[':+ count++;+ if (tokens == NULL) {+ break;+ }+ token = jsmn_alloc_token(parser, tokens, num_tokens);+ if (token == NULL) {+ return JSMN_ERROR_NOMEM;+ }+ if (parser->toksuper != -1) {+ jsmntok_t *t = &tokens[parser->toksuper];+#ifdef JSMN_STRICT+ /* In strict mode an object or array can't become a key */+ if (t->type == JSMN_OBJECT) {+ return JSMN_ERROR_INVAL;+ }+#endif+ t->size++;+#ifdef JSMN_PARENT_LINKS+ token->parent = parser->toksuper;+#endif+ }+ token->type = (c == '{' ? JSMN_OBJECT : JSMN_ARRAY);+ token->start = parser->pos;+ parser->toksuper = parser->toknext - 1;+ break;+ case '}':+ case ']':+ if (tokens == NULL) {+ break;+ }+ type = (c == '}' ? JSMN_OBJECT : JSMN_ARRAY);+#ifdef JSMN_PARENT_LINKS+ if (parser->toknext < 1) {+ return JSMN_ERROR_INVAL;+ }+ token = &tokens[parser->toknext - 1];+ for (;;) {+ if (token->start != -1 && token->end == -1) {+ if (token->type != type) {+ return JSMN_ERROR_INVAL;+ }+ token->end = parser->pos + 1;+ parser->toksuper = token->parent;+ break;+ }+ if (token->parent == -1) {+ if (token->type != type || parser->toksuper == -1) {+ return JSMN_ERROR_INVAL;+ }+ break;+ }+ token = &tokens[token->parent];+ }+#else+ for (i = parser->toknext - 1; i >= 0; i--) {+ token = &tokens[i];+ if (token->start != -1 && token->end == -1) {+ if (token->type != type) {+ return JSMN_ERROR_INVAL;+ }+ parser->toksuper = -1;+ token->end = parser->pos + 1;+ break;+ }+ }+ /* Error if unmatched closing bracket */+ if (i == -1) {+ return JSMN_ERROR_INVAL;+ }+ for (; i >= 0; i--) {+ token = &tokens[i];+ if (token->start != -1 && token->end == -1) {+ parser->toksuper = i;+ break;+ }+ }+#endif+ break;+ case '\"':+ r = jsmn_parse_string(parser, js, len, tokens, num_tokens);+ if (r < 0) {+ return r;+ }+ count++;+ if (parser->toksuper != -1 && tokens != NULL) {+ tokens[parser->toksuper].size++;+ }+ break;+ case '\t':+ case '\r':+ case '\n':+ case ' ':+ break;+ case ':':+ parser->toksuper = parser->toknext - 1;+ break;+ case ',':+ if (tokens != NULL && parser->toksuper != -1 &&+ tokens[parser->toksuper].type != JSMN_ARRAY &&+ tokens[parser->toksuper].type != JSMN_OBJECT) {+#ifdef JSMN_PARENT_LINKS+ parser->toksuper = tokens[parser->toksuper].parent;+#else+ for (i = parser->toknext - 1; i >= 0; i--) {+ if (tokens[i].type == JSMN_ARRAY || tokens[i].type == JSMN_OBJECT) {+ if (tokens[i].start != -1 && tokens[i].end == -1) {+ parser->toksuper = i;+ break;+ }+ }+ }+#endif+ }+ break;+#ifdef JSMN_STRICT+ /* In strict mode primitives are: numbers and booleans */+ case '-':+ case '0':+ case '1':+ case '2':+ case '3':+ case '4':+ case '5':+ case '6':+ case '7':+ case '8':+ case '9':+ case 't':+ case 'f':+ case 'n':+ /* And they must not be keys of the object */+ if (tokens != NULL && parser->toksuper != -1) {+ const jsmntok_t *t = &tokens[parser->toksuper];+ if (t->type == JSMN_OBJECT ||+ (t->type == JSMN_STRING && t->size != 0)) {+ return JSMN_ERROR_INVAL;+ }+ }+#else+ /* In non-strict mode every unquoted value is a primitive */+ default:+#endif+ r = jsmn_parse_primitive(parser, js, len, tokens, num_tokens);+ if (r < 0) {+ return r;+ }+ count++;+ if (parser->toksuper != -1 && tokens != NULL) {+ tokens[parser->toksuper].size++;+ }+ break;++#ifdef JSMN_STRICT+ /* Unexpected char in strict mode */+ default:+ return JSMN_ERROR_INVAL;+#endif+ }+ }++ if (tokens != NULL) {+ for (i = parser->toknext - 1; i >= 0; i--) {+ /* Unmatched opened object or array */+ if (tokens[i].start != -1 && tokens[i].end == -1) {+ return JSMN_ERROR_PART;+ }+ }+ }++ return count;+}++/**+ * Creates a new parser based over a given buffer with an array of tokens+ * available.+ */+JSMN_API void jsmn_init(jsmn_parser *parser) {+ parser->pos = 0;+ parser->toknext = 0;+ parser->toksuper = -1;+}++#endif /* JSMN_HEADER */++#ifdef __cplusplus+}+#endif++#endif /* JSMN_H */
+ test/Env.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}++module Env where++import Web.Libjwt ( RsaKeyPair(..)+ , EcKeyPair(..)+ )++import Control.Arrow ( left )++import Control.Monad.Catch++import Control.Monad.Time++import Control.Monad.Trans.Reader ( ReaderT+ , runReaderT+ )++import qualified Data.ByteString.Char8 as C8++import Data.Either.Extra ( fromEither )++import Data.Time.Clock ( UTCTime )+import Data.Time.Clock.POSIX ( POSIXTime+ , posixSecondsToUTCTime+ )++import Data.UUID ( UUID )++import Test.Hspec ( Expectation+ , expectationFailure+ , Spec+ )+import qualified Test.Hspec as HSpec+++testJTI :: UUID+testJTI = read "5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"++testRsa2048KeyPair :: RsaKeyPair+testRsa2048KeyPair =+ let privKey = C8.pack $ unlines+ [ "-----BEGIN RSA PRIVATE KEY-----"+ , "MIIEpgIBAAKCAQEAwCXp2P+qboao0tjUyU+D3YI+sgBn8dkGaxOvPFLBFQMNkhbL"+ , "0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclROXocRWUn5s2W3jP5xn7lM4otIpuE"+ , "3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHVEuGMM7oddiB6s3zjwf2h1v0SEiHf"+ , "5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3JcaWW+eDk/UU3jCfCke7R3t2rbD1ZC"+ , "j1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcpd8iz0ZTLaG8Qnm0GsPQjR3PTZYEC"+ , "xEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5YboxQIDAQABAoIBAQCg/OMBsauc8Ovv"+ , "xEX76MglxeM7hgWQ5vFus05lrzwgm686EClxme1QHMv8QszuXzSjuEFs4SQH9K82"+ , "p2z+UgrgqkOXjNoykVvvDgMe4OCuHv4T+dMGO1hTrXfXawKI2Lhg1/1bzX+u5ii9"+ , "mfbsUUixihHKoQvgFfRX/7JfrV50XZ3diwzd8DoEaIgeAIdyhLhVuh2W7wXbOF+l"+ , "aZW7gqCVzTBhC04E/D6eqFqvnkQyHzZPgaaDi4oL7gP8nGpcswlqKSLO5eVkkEHY"+ , "C88nAwU4Q/+qcAf09ijmTLlo07xLrLC0cOf2yQTwLj6ZffzTJ7NSMaPrTdEXThsW"+ , "wAeB/GcBAoGBAOzLST9/zakFGBTkwiLqgNVgEBUoYjB0Z+Fpx4qBLzKZNQP1yNup"+ , "LhC/4pIVQM+ZjOS0Wx7Sh0FTLHFb018quPiAPsKMEC2CW5v7vKwC4zW72/v5UrIw"+ , "pcBzl67nsc53r5Lblol9PU4oCjDzuFMjMbg+EzD3kVp/gxC9bRMwK3zBAoGBAM+7"+ , "nOV80uteB1ZXazccj6g0ANd2AyJY6gHfxD1CopvRReYm36wmG00HQ3jHZPUcsLQp"+ , "dWvWplRFprZlce0jl7HcB/8g5wUkErMop3KK5cA886HxsATNSl6rYghZGALqxm/a"+ , "+v2AKoZThns8QRYL5bsBD4kTQLEIwp7j6sNbBrkFAoGBAL6fL8o0gkUsWqSHO1mM"+ , "WkZrXMcLiW/kZbPqyb3QHUSoXStg818RpInLTwO2pEP7IpcCMdBwPn3yDPb8qv4T"+ , "kHBMHTnUMznPlRvO3aXDdVFOd9sybMYRr31sEJG250aExwx8RYVNEssWJI4fxST4"+ , "UhA1uJFU2uh1efdB5srpnjiBAoGBALTDCPAZAmCVXcUgJMe8LrWrKuBSbL/Cpz4i"+ , "PV0hUuZL4Is5YIEoV7FblLbQq2UvJgRf3zGLgwjp4vvsooo74pB+auby9pReo3cK"+ , "9UqS2wHBCC/vY7+J9CEU+SVSgbZoHWzQHH/iux5QKEGsWOaaS7nCXoZlHnHusYwZ"+ , "v/tmhh8RAoGBAIi3Lbup0AVwougANLXwMLCfT8HxI8Hozdr+Pe0ibTnjfY+BPuy1"+ , "vSgozXao68TwW3u58PcdvfBnfg/7XCK6TXtij48JDu6qw0IiSRxOZ5Ed/GW2P031"+ , "7TfwnjBohjM2O6NRne8qe6Qv5xLagoVKQfa1WhQEFU2bTNLYA/2kv266"+ , "-----END RSA PRIVATE KEY-----"+ ]+ pubKey = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwCXp2P+qboao0tjUyU+D"+ , "3YI+sgBn8dkGaxOvPFLBFQMNkhbL0HEoRKNnQCubZNc0jXnMK5hCeGRnDS7lYclR"+ , "OXocRWUn5s2W3jP5xn7lM4otIpuE3FStthMCrPSEQiBCXE4cyKiHaZqmbqXlHAHV"+ , "EuGMM7oddiB6s3zjwf2h1v0SEiHf5ZFzTVarStablqh6wVDAiYyM+8aUM0x9p3Jc"+ , "aWW+eDk/UU3jCfCke7R3t2rbD1ZCj1cO08Uir3Lhf65TfU+iIrgLU3umV4B3gRcp"+ , "d8iz0ZTLaG8Qnm0GsPQjR3PTZYECxEnFaRgXcQLHYYMAW9YaX6T3rlTGZAaP5Ybo"+ , "xQIDAQAB"+ , "-----END PUBLIC KEY-----"+ ]+ in FromRsaPem { privKey, pubKey }++testEcP256KeyPair :: EcKeyPair+testEcP256KeyPair =+ let ecPrivKey = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MHcCAQEEINQ0e0KOa3EZSB5RTd2xBuO3O7NNFietDIWl+B+R38LuoAoGCCqGSM49"+ , "AwEHoUQDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FNlsrCnaXRoJUVdOYZldzb4po2"+ , "uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+ , "-----END EC PRIVATE KEY-----"+ ]+ ecPubKey = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MFkwEwYHKoZIzj0CAQYIKoZIzj0DAQcDQgAEKZL0X84AvdnGZdsIdAS60OnvF3FN"+ , "lsrCnaXRoJUVdOYZldzb4po2uDXF5W58DS8C31fV+z+0lTG5RvuAqfkdbA=="+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey, ecPubKey }++testEcP384KeyPair :: EcKeyPair+testEcP384KeyPair =+ let ecPrivKey = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MIGkAgEBBDBo23gVhrmZIkAAUDzb1FK9Ajdv5ehXcTedZea0uW2xx6WK/VCyCLvv"+ , "XZXK77d7dPmgBwYFK4EEACKhZANiAAQT7mlkd/dKcTa7jxiClVEPS+b8BOpZZeft"+ , "h2GS5p6wR2qWt8eb9cxGWG8ArWbXHBKvX9BMoHOVgVhfVkdGPDD8GkU97gLP7jbW"+ , "A9lWwFMt6xEEGm/yKupVyZ9p9PAZaWU="+ , "-----END EC PRIVATE KEY-----"+ ]+ ecPubKey = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MHYwEAYHKoZIzj0CAQYFK4EEACIDYgAEE+5pZHf3SnE2u48YgpVRD0vm/ATqWWXn"+ , "7YdhkuaesEdqlrfHm/XMRlhvAK1m1xwSr1/QTKBzlYFYX1ZHRjww/BpFPe4Cz+42"+ , "1gPZVsBTLesRBBpv8irqVcmfafTwGWll"+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey, ecPubKey }++testEcP521KeyPair :: EcKeyPair+testEcP521KeyPair =+ let ecPrivKey = C8.pack $ unlines+ [ "-----BEGIN EC PRIVATE KEY-----"+ , "MIHcAgEBBEIAIWLn8LIw+NC3gZJIFemY/Ku5QNNncVjNZiQdICh7KzgHPrjCrdQk"+ , "2HNAZ+7r5biSu07Kucvn7OLbubL8iFykX8GgBwYFK4EEACOhgYkDgYYABAGgIDu0"+ , "FLPpH0NNAzlqrRW3IClcxSZt043iTdwLTmbMj51epCDDPb04jfdDWg58pQqXRKEI"+ , "xRUJbv/6aJimWkfkvwBsHhdkIdXSTID9wKTaCSkeGAqGdzjkBdTMA8sfEujYDtHt"+ , "FoCrBx31I4jnh2yX1WNa9oycus38E6IzWeTdq547aA=="+ , "-----END EC PRIVATE KEY-----"+ ]+ ecPubKey = C8.pack $ unlines+ [ "-----BEGIN PUBLIC KEY-----"+ , "MIGbMBAGByqGSM49AgEGBSuBBAAjA4GGAAQBoCA7tBSz6R9DTQM5aq0VtyApXMUm"+ , "bdON4k3cC05mzI+dXqQgwz29OI33Q1oOfKUKl0ShCMUVCW7/+miYplpH5L8AbB4X"+ , "ZCHV0kyA/cCk2gkpHhgKhnc45AXUzAPLHxLo2A7R7RaAqwcd9SOI54dsl9VjWvaM"+ , "nLrN/BOiM1nk3aueO2g="+ , "-----END PUBLIC KEY-----"+ ]+ in FromEcPem { ecPrivKey, ecPubKey }+++newtype TestEnv a = MkTest { runTest :: ReaderT UTCTime (Either SomeException) a }+ deriving newtype (Functor, Applicative, Monad, MonadTime, MonadThrow, MonadCatch)++pass :: TestEnv Expectation+pass = MkTest (pure alwaysTrue) where alwaysTrue = pure ()++presetTime :: UTCTime+presetTime = posixSecondsToUTCTime 1595386660++runTestWithPresetTime :: TestEnv a -> Either SomeException a+runTestWithPresetTime = runTestWithGivenTime presetTime++runTestWithGivenTime :: UTCTime -> TestEnv a -> Either SomeException a+runTestWithGivenTime time = ($ time) . runReaderT . runTest++specify :: String -> TestEnv Expectation -> Spec+specify name = HSpec.specify name . runExpectationWithPresetTime++specifyWithTime :: POSIXTime -> String -> TestEnv Expectation -> Spec+specifyWithTime t0 name =+ HSpec.specify name . runExpectationWithTime (posixSecondsToUTCTime t0)++xspecify :: String -> TestEnv Expectation -> Spec+xspecify name = HSpec.xspecify name . runExpectationWithPresetTime++runExpectationWithPresetTime :: TestEnv Expectation -> Expectation+runExpectationWithPresetTime = runExpectationWithTime presetTime++runExpectationWithTime :: UTCTime -> TestEnv Expectation -> Expectation+runExpectationWithTime t0 =+ fromEither+ . left+ (\e ->+ expectationFailure+ $ "unexpected exception thrown while running the test: "+ ++ displayException e+ )+ . runTestWithGivenTime t0++
+ test/Generators.hs view
@@ -0,0 +1,258 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Generators+ ( JwtString(..)+ , JwtText(..)+ , genHeader+ , genJwt+ , shrinkJwt+ )+where++import Web.Libjwt+import qualified Env as E+import Libjwt.Classes+import Libjwt.NumericDate ( toPOSIX )++import Control.Applicative ( liftA2 )++import Data.Aeson ( FromJSON+ , ToJSON+ )++import Data.ByteString ( ByteString )++import Data.Coerce++import Data.Text ( Text )+import qualified Data.Text as T++import Data.UUID ( UUID )++import Test.QuickCheck++import Test.QuickCheck.Instances ( )++import Prelude hiding ( exp )+++instance Arbitrary Iss where+ arbitrary = genIss+ shrink = shrinkIss++genIss :: Gen Iss+genIss = coerce genMaybeShortPrintable++shrinkIss :: Iss -> [Iss]+shrinkIss (Iss x) = coerce $ shrink x++instance Arbitrary Sub where+ arbitrary = genSub+ shrink = shrinkSub++genSub :: Gen Sub+genSub = coerce genMaybeShortPrintable++shrinkSub :: Sub -> [Sub]+shrinkSub (Sub x) = coerce $ shrink x++instance Arbitrary Jti where+ arbitrary = genJti++genJti :: Gen Jti+genJti = coerce $ arbitrary @(Maybe UUID)++instance Arbitrary NumericDate where+ arbitrary = genNumericDate+ shrink = shrinkNumericDate++genNumericDate :: Gen NumericDate+genNumericDate = fromPOSIX <$> arbitrary `suchThat` (>= 0)++shrinkNumericDate :: NumericDate -> [NumericDate]+shrinkNumericDate = shrinkMap fromPOSIX toPOSIX++instance Arbitrary Exp where+ arbitrary = genExp+ shrink = shrinkExp++genExp :: Gen Exp+genExp = coerce $ arbitrary @(Maybe NumericDate)++shrinkExp :: Exp -> [Exp]+shrinkExp (Exp x) = coerce $ shrink x++instance Arbitrary Nbf where+ arbitrary = genNbf+ shrink = shrinkNbf++genNbf :: Gen Nbf+genNbf = coerce $ arbitrary @(Maybe NumericDate)++shrinkNbf :: Nbf -> [Nbf]+shrinkNbf (Nbf x) = coerce $ shrink x++instance Arbitrary Iat where+ arbitrary = genIat+ shrink = shrinkIat++genIat :: Gen Iat+genIat = coerce $ arbitrary @(Maybe NumericDate)++shrinkIat :: Iat -> [Iat]+shrinkIat (Iat x) = coerce $ shrink x++instance Arbitrary Aud where+ arbitrary = genAud+ shrink = shrinkAud++genAud :: Gen Aud+genAud =+ coerce $ frequency [(8, pure []), (2, resize 5 $ listOf genShortPrintable)]++shrinkAud :: Aud -> [Aud]+shrinkAud (Aud aud) = coerce $ shrink aud++instance Arbitrary ASCII where+ arbitrary = genASCII+ shrink = shrinkASCII++genASCII :: Gen ASCII+genASCII = coerce $ listOf $ arbitraryASCIIChar `suchThat` (/= '\NUL')++shrinkASCII :: ASCII -> [ASCII]+shrinkASCII = coerce . filter (notElem '\NUL') . shrink . getASCII++instance Arbitrary a => Arbitrary (Flag a) where+ arbitrary = coerce $ arbitrary @a++instance Arbitrary Alg where+ arbitrary = genAlg++genAlg :: Gen Alg+genAlg = elements [hs256, hs512, rs256, rs512, es256, es384, es512, None]+ where+ hs256 =+ HS256+ "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\+ \NDg3NDBkMiAgLQo"+ hs512 =+ HS512+ "MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\+ \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\+ \Y2IwMDZhYWY1MjY1OTQgIC0K"+ rs256 = RS256 E.testRsa2048KeyPair+ rs512 = RS512 E.testRsa2048KeyPair+ es256 = ES256 E.testEcP256KeyPair+ es384 = ES384 E.testEcP384KeyPair+ es512 = ES512 E.testEcP521KeyPair++instance Arbitrary ValidationSettings where+ arbitrary = Settings <$> genLeeway <*> arbitrary+ where genLeeway = arbitrary `suchThat` (>= 0)+ shrink Settings { leeway, appName } =+ Settings <$> shrinkLeeway leeway <*> shrink appName+ where shrinkLeeway = filter (>= 0) . shrink++newtype JwtString = S { correctJwtString :: String }+ deriving newtype (JwtRep ByteString, Show, Eq)++correctJwtChar :: Char -> Bool+correctJwtChar '\NUL' = False+correctJwtChar '\65534' = False+correctJwtChar '\65535' = False+correctJwtChar _ = True++instance Arbitrary JwtString where+ arbitrary = coerce $ listOf $ arbitrary `suchThat` correctJwtChar+ shrink = coerce . filter (all correctJwtChar) . shrink . correctJwtString++newtype JwtText = T { correctJwtText :: Text }+ deriving newtype (JwtRep ByteString, Show, Eq, JsonBuilder, JsonParser, FromJSON, ToJSON)++instance Arbitrary JwtText where+ arbitrary = coerce $ T.pack . correctJwtString <$> arbitrary+ shrink =+ shrinkMap (T . T.pack . correctJwtString) $ S . T.unpack . correctJwtText++instance Arbitrary Header where+ arbitrary = genHeader++genHeader :: Gen Header+genHeader = Header <$> genAlg <*> pure JWT++instance Arbitrary (PrivateClaims ts ns) => Arbitrary (Jwt ts ns) where+ arbitrary = genJwt+ shrink = shrinkJwt++genJwt :: Arbitrary (PrivateClaims ts ns) => Gen (Jwt ts ns)+genJwt = Jwt <$> genHeader <*> arbitrary++shrinkJwt :: Arbitrary (PrivateClaims pc ns) => Jwt pc ns -> [Jwt pc ns]+shrinkJwt jwt = shrinkMap (\payload' -> jwt { payload = payload' }) payload jwt++instance Arbitrary (PrivateClaims ts ns) => Arbitrary (Payload ts ns) where+ arbitrary =+ ClaimsSet+ <$> genIss+ <*> genSub+ <*> genAud+ <*> genExp+ <*> genNbf+ <*> genIat+ <*> genJti+ <*> arbitrary++ shrink ClaimsSet { iss, sub, aud, exp, nbf, iat, jti, privateClaims } =+ tail+ $ ClaimsSet+ <$> shrink' iss+ <*> shrink' sub+ <*> shrink' aud+ <*> shrink' exp+ <*> shrink' nbf+ <*> shrink' iat+ <*> shrink' jti+ <*> shrink' privateClaims+ where shrink' x = x : shrink x++instance Arbitrary (PrivateClaims Empty 'NoNs) where+ arbitrary = pure nullClaims++instance+ ( Arbitrary a+ , CanAdd n tl+ , Arbitrary (PrivateClaims tl 'NoNs)+ )+ => Arbitrary (PrivateClaims (n ->> a ': tl) 'NoNs) where+ arbitrary = liftA2 (.:) genWitness arbitrary+ shrink (a :< tl) = tail+ $ liftA2 (.:) (map (ClaimName ->>) $ shrink' a) (shrink' tl)+ where shrink' x = x : shrink x++instance Arbitrary (PrivateClaims ts 'NoNs) => Arbitrary (PrivateClaims ts ('SomeNs ns)) where+ arbitrary = someNs Ns <$> arbitrary+ shrink = shrinkMap (someNs Ns) noNs++genWitness :: Arbitrary a => Gen (ClaimWitness name a)+genWitness = (ClaimName ->>) <$> arbitrary++genShortPrintable :: Gen PrintableString+genShortPrintable = resize 32 arbitrary++genMaybeShortPrintable :: Gen (Maybe PrintableString)+genMaybeShortPrintable = liftArbitrary genShortPrintable+
+ test/Interop/JWTDecoding.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Interop.JWTDecoding+ ( spec+ )+where++import Web.Libjwt+import qualified Env as E+import Interop.JWTHelpers++import Control.Monad.Catch++import qualified Data.Aeson as JSON++import qualified Data.Either.Validation as V++import qualified Data.List.NonEmpty as NEL++import qualified Data.Map.Strict as Map++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Data.Time.Clock ( UTCTime )++import qualified Data.UUID as UUID+++import GHC.Generics++import Prelude hiding ( exp )++import Test.Hspec++import qualified Web.JWT as JWT+++spec :: Spec+spec = do+ describe "HS256"+ $ runTests+ $ HS256+ "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\+ \NDg3NDBkMiAgLQo"+ describe "none" $ runTests None+ describe "RS256" $ runTests $ RS256 E.testRsa2048KeyPair++runTests :: Alg -> Spec+runTests a = sequence_ $ tests <*> [a]++tests :: [Alg -> Spec]+tests =+ [ basicTest+ , typTest+ , richHeaderTest+ , audSingleTest+ , audListTest+ , unregisteredClaimsTest+ , unregisteredClaimsNsTest+ , unregisteredClaimsOptionsTest+ , utfTest+ , invalidClaimTest+ , invalidOptClaimTest+ , validTokenTest+ , invalidTokenTest+ ]++basicTest :: Alg -> Spec+basicTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test"+ , JWT.iat = JWT.numericDate 1595386660+ , JWT.nbf = JWT.numericDate 1595386660+ }+ in E.specify "basic" $ mkTest joseHeader cs a nullClaims++typTest :: Alg -> Spec+typTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "jose") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-typ"+ }+ in E.xspecify "typ" $ mkTest joseHeader cs a nullClaims -- Web.JWT always uses JWT++richHeaderTest :: Alg -> Spec+richHeaderTest a =+ let joseHeader = JWT.JOSEHeader (Just "JWT")+ (Just "test")+ (mkJWTAlgorithm a)+ (Just "test")+ cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-rich-header"+ }+ in E.specify "rich-header" $ mkTest joseHeader cs a nullClaims++audSingleTest :: Alg -> Spec+audSingleTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-aud-single"+ , JWT.aud = Left <$> JWT.stringOrURI "nobody"+ }+ in E.specify "aud-single" $ mkTest joseHeader cs a nullClaims++audListTest :: Alg -> Spec+audListTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-aud-list"+ , JWT.aud = fmap Right+ . sequence+ $ [JWT.stringOrURI]+ <*> ["nobody-1", "nobody-2", "nobody-3"]+ }+ in E.specify "aud-list" $ mkTest joseHeader cs a nullClaims++data PreferredContact = Email | Phone+ deriving stock (Show, Eq, Generic)++instance AFlag PreferredContact++unregisteredClaimsTest :: Alg -> Spec+unregisteredClaimsTest a =+ let+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-unregistered"+ , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList+ [ ("name" , JSON.String "John Doe")+ , ("userId" , JSON.Number 12345)+ , ("isAdmin" , JSON.Bool False)+ , ("preferredContact", JSON.String "email")+ , ("systemId" , JSON.String $ UUID.toText E.testJTI)+ , ("createdAt" , JSON.String "2020-07-31T11:45:00Z")+ ]+ }+ in+ E.specify "unregistered-claims" $ mkTest joseHeader cs a $ toPrivateClaims+ ( #name ->> ("John Doe" :: String)+ , #userId ->> (12345 :: Int)+ , #isAdmin ->> False+ , #preferredContact ->> Flag Email+ , #systemId ->> E.testJTI+ , #createdAt ->> Just (read "2020-07-31 11:45:00 UTC" :: UTCTime)+ )++unregisteredClaimsOptionsTest :: Alg -> Spec+unregisteredClaimsOptionsTest a =+ let+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-unregistered-opt"+ , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList+ [ ("name", JSON.String "John Doe")+ , ("userId" , JSON.Number 12345)+ , ("isAdmin" , JSON.Bool False)+ , ("preferredContact", JSON.String "email")+ ]+ }+ in+ E.specify "unregistered-claims-options"+ $ mkTest joseHeader cs a+ $ toPrivateClaims+ ( #name ->> ("John Doe" :: String)+ , #userId ->> (12345 :: Int)+ , #isAdmin ->> False+ , #preferredContact ->> Just (Flag Email)+ , #systemId ->> (Nothing :: Maybe UUID.UUID)+ , #prefs ->> ([] :: [String])+ )++unregisteredClaimsNsTest :: Alg -> Spec+unregisteredClaimsNsTest a =+ let+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-unregistered"+ , JWT.iat = JWT.numericDate 1595386660+ , JWT.nbf = JWT.numericDate 1595386660+ , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList+ [ ("http://example.com/name" , JSON.String "John Doe")+ , ("http://example.com/userId" , JSON.Number 12345)+ , ("http://example.com/isAdmin" , JSON.Bool False)+ , ("http://example.com/systemId", JSON.String $ UUID.toText E.testJTI)+ ]+ }+ in+ E.specify "unregistered-claims-ns"+ $ mkTest joseHeader cs a+ $ toPrivateClaims+ $ withNs+ (Ns @"http://example.com")+ ( #name ->> ("John Doe" :: String)+ , #userId ->> (12345 :: Int)+ , #isAdmin ->> False+ , #systemId ->> E.testJTI+ )++utfTest :: Alg -> Spec+utfTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "test-utf"+ , JWT.unregisteredClaims = JWT.ClaimsMap $ Map.fromList+ [ ("name" , JSON.String "孔子")+ , ("status", JSON.String "不患人之不己知，患不知人也")+ ]+ }+ in E.specify "utf" $ mkTest joseHeader cs a $ toPrivateClaims+ (#name ->> ("孔子" :: String), #status ->> ("不患人之不己知，患不知人也" :: T.Text))++invalidClaimTest :: Alg -> Spec+invalidClaimTest a =+ let joseHeader =+ JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "invalid-claim-test"+ , JWT.unregisteredClaims = JWT.ClaimsMap+ $ Map.singleton "not-a-number" JSON.Null+ }+ token = jwtEncode cs joseHeader a+ in E.specify "invalid-claim"+ $ decodeTest @'["not-a-number" ->> Int] @ 'NoNs+ a+ token+ (\decoded ->+ expectationFailure+ $ "Web.JWT: unexpectedly decoded token\n"+ ++ show token+ ++ "\n to: "+ ++ show decoded+ )+ `catch` (\(Missing missing) -> pure $ missing `shouldBe` "not-a-number")++invalidOptClaimTest :: Alg -> Spec+invalidOptClaimTest a =+ let+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "invalid-opt-claim-test"+ , JWT.unregisteredClaims = JWT.ClaimsMap+ $ Map.singleton "maybeNumber" JSON.Null+ }+ in+ E.specify "invalid-opt-claim"+ $ mkTest joseHeader cs a+ $ toPrivateClaims+ $ #maybeNumber+ ->> (Nothing :: Maybe Int)++validTokenTest :: Alg -> Spec+validTokenTest a =+ let+ t0 = 1597945008+ ttl = 60+ t1 = t0 + 30+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "valid-token-test"+ , JWT.iat = JWT.numericDate t0+ , JWT.exp = JWT.numericDate $ t0 + ttl+ , JWT.nbf = JWT.numericDate t0+ , JWT.unregisteredClaims =+ JWT.ClaimsMap $ Map.singleton "number" $ JSON.Number 30+ }+ in+ E.specifyWithTime t1 "valid-token"+ $ validationTest @'["number" ->> Int] @ 'NoNs+ a+ (jwtEncode cs joseHeader a)+ ( checkAge 3600+ <> checkIssuer "libjwt-typed-test"+ <> checkSubject "valid-token-test"+ <> checkClaim (> 0) #number+ )+ $ \result -> result `shouldSatisfy` \case+ (V.Success _) -> True+ (V.Failure _) -> False++invalidTokenTest :: Alg -> Spec+invalidTokenTest a =+ let+ t0 = 1597945008+ ttl = 60+ t1 = t0 + 120+ joseHeader = JWT.JOSEHeader (Just "JWT") Nothing (mkJWTAlgorithm a) Nothing+ cs = mempty+ { JWT.iss = JWT.stringOrURI "libjwt-typed-test"+ , JWT.sub = JWT.stringOrURI "invalid-token-test"+ , JWT.iat = JWT.numericDate t0+ , JWT.exp = JWT.numericDate $ t0 + ttl+ , JWT.nbf = JWT.numericDate t0+ , JWT.unregisteredClaims =+ JWT.ClaimsMap $ Map.singleton "number" $ JSON.Number (-30)+ }+ in+ E.specifyWithTime t1 "invalid-token"+ $ validationTest @'["number" ->> Int] @ 'NoNs+ a+ (jwtEncode cs joseHeader a)+ ( checkAge 3600+ <> checkIssuer "libjwt-typed-test"+ <> checkSubject "valid-token-test"+ <> checkClaim (> 0) #number+ )+ $ \result -> result `shouldSatisfy` \case+ (V.Success _) -> False+ (V.Failure errors) ->+ let es = NEL.toList errors+ in all (`elem` es)+ [TokenExpired 60, InvalidClaim "number", InvalidClaim "sub"]++mkTest+ :: ( Show (PrivateClaims cs ns)+ , Eq (PrivateClaims cs ns)+ , Decode (PrivateClaims cs ns)+ )+ => JWT.JOSEHeader+ -> JWT.JWTClaimsSet+ -> Alg+ -> PrivateClaims cs ns+ -> E.TestEnv Expectation+mkTest inHeader inClaims a expected =+ let token = jwtEncode inClaims inHeader a+ in handle (handleDecodeException token) $ decodeTest a token $ \jwt -> do+ expectHeader inHeader $ header jwt+ expectPayload inClaims (payload jwt) expected++decodeTest+ :: Decode (PrivateClaims pc ns)+ => Alg+ -> T.Text+ -> (Jwt pc ns -> Expectation)+ -> E.TestEnv Expectation+decodeTest a token test =+ fmap (test . getDecoded) $ E.MkTest $ decodeByteString a $ TE.encodeUtf8 token++validationTest+ :: Decode (PrivateClaims pc ns)+ => Alg+ -> T.Text+ -> JwtValidation pc ns+ -> ( ValidationNEL ValidationFailure (Validated (Jwt pc ns))+ -> Expectation+ )+ -> E.TestEnv Expectation+validationTest a token validation test =+ fmap test+ $ E.MkTest+ $ jwtFromByteString defaultValidationSettings validation a+ $ TE.encodeUtf8 token++jwtEncode :: JWT.JWTClaimsSet -> JWT.JOSEHeader -> Alg -> T.Text+jwtEncode inClaims inHeader =+ maybe (JWT.encodeUnsigned inClaims inHeader)+ (\signer -> JWT.encodeSigned signer inHeader inClaims)+ . mkSigner++handleDecodeException :: T.Text -> SomeDecodeException -> E.TestEnv Expectation+handleDecodeException token e =+ pure+ $ expectationFailure+ $ "Web.JWT: Decoding token\n"+ ++ show token+ ++ "\n\tthrew exception:\n"+ ++ show e++expectHeader :: JWT.JOSEHeader -> Header -> Expectation+expectHeader expected got = do+ typ got `shouldBe` typ' (JWT.typ expected)+ mkJWTAlgorithm (alg got) `shouldBe` JWT.alg expected+ where+ typ' Nothing = Typ Nothing+ typ' (Just "JWT") = JWT+ typ' (Just "jwt") = JWT+ typ' (Just text ) = Typ $ Just $ TE.encodeUtf8 text++expectPayload+ :: (Show (PrivateClaims cs ns), Eq (PrivateClaims cs ns))+ => JWT.JWTClaimsSet+ -> Payload cs ns+ -> PrivateClaims cs ns+ -> Expectation+expectPayload expected got expectedPc = got `shouldBe` ClaimsSet+ { iss = iss' (JWT.iss expected)+ , sub = sub' (JWT.sub expected)+ , aud = aud' (JWT.aud expected)+ , exp = exp' (JWT.exp expected)+ , iat = iat' (JWT.iat expected)+ , nbf = nbf' (JWT.nbf expected)+ , jti = jti' (JWT.jti expected)+ , privateClaims = expectedPc+ }+ where+ stringOrURIToString = T.unpack . JWT.stringOrURIToText++ intDateToNumericDate = fromPOSIX . JWT.secondsSinceEpoch++ iss' mt = Iss $ stringOrURIToString <$> mt++ sub' mt = Sub $ stringOrURIToString <$> mt++ aud' Nothing = mempty+ aud' (Just (Left s )) = Aud [stringOrURIToString s]+ aud' (Just (Right ss)) = Aud $ map stringOrURIToString ss++ exp' md = Exp $ intDateToNumericDate <$> md++ iat' md = Iat $ intDateToNumericDate <$> md++ nbf' md = Nbf $ intDateToNumericDate <$> md++ jti' mt = Jti $ UUID.fromText . JWT.stringOrURIToText =<< mt
+ test/Interop/JWTEncoding.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Interop.JWTEncoding+ ( spec+ )+where++import Web.Libjwt+import qualified Env as E+import Interop.JWTHelpers+import Libjwt.NumericDate ( toPOSIX )++import qualified Data.Aeson as JSON++import qualified Data.Map.Strict as Map++import Data.Maybe ( fromMaybe )++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import qualified Data.UUID as UUID++import GHC.Generics++import Prelude hiding ( exp )++import Test.Hspec++import qualified Web.JWT as JWT+++spec :: Spec+spec = do+ describe "HS256"+ $ runTests+ $ HS256+ "MWNmYzExODA5OWFjOGM3NDNmMmM5Zjg5ZDc0YTM3M2VhMGNkMzA2MDY3ZjFhZDk5N2I3OTc5Yjdm\+ \NDg3NDBkMiAgLQo"+ xdescribe "none" $ runTests None -- JWT does not work at all with none+ describe "RS256" $ runTests $ RS256 E.testRsa2048KeyPair++runTests :: Alg -> Spec+runTests alg = sequence_ $ tests <*> [alg]++tests :: [Alg -> Spec]+tests =+ [ basicTest+ , typTest+ , audSingleTest+ , audListTest+ , privateClaimsSimpleTest+ , privateClaimsComplexTest+ , privateClaimsNsTest+ , utfTest+ ]++basicTest :: Alg -> Spec+basicTest alg =+ E.specify "basic"+ $ mkTest Header { alg, typ = JWT } mempty+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test"+ <> issuedNow+ <> notBeforeNow+ <> withJwtId E.testJTI+ )+ ()++typTest :: Alg -> Spec+typTest alg =+ E.specify "typ"+ $ mkTest Header { alg, typ = Typ $ Just "jose" } mempty+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-typ"+ <> withJwtId E.testJTI+ )+ ()++audSingleTest :: Alg -> Spec+audSingleTest alg =+ E.specify "aud-single"+ $ mkTest Header { alg, typ = JWT } mempty+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-aud-single"+ <> withRecipient "nobody"+ )+ ()++audListTest :: Alg -> Spec+audListTest alg =+ E.specify "aud-list"+ $ mkTest Header { alg, typ = JWT } mempty+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-aud-list"+ <> withRecipient "nobody-1"+ <> withRecipient "nobody-2"+ <> withRecipient "nobody-3"+ )+ ()++privateClaimsSimpleTest :: Alg -> Spec+privateClaimsSimpleTest alg =+ E.specify "private-claims-simple"+ $ mkTest+ Header { alg, typ = JWT }+ (JWT.ClaimsMap $ Map.fromList+ [ ("name" , JSON.String "John Doe")+ , ("userId" , JSON.Number 12345)+ , ("isAdmin", JSON.Bool False)+ ]+ )+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-private-claims-simple"+ )+ ( #name ->> ("John Doe" :: String)+ , #userId ->> (12345 :: Int)+ , #isAdmin ->> False+ )++data UserRole = Admin | RegularUser+ deriving stock (Show, Eq, Generic)++instance AFlag UserRole++data ClaimObj = MkClaims { name :: String, userId :: Int, role :: Flag UserRole }+ deriving stock Generic++instance ToPrivateClaims ClaimObj+instance FromPrivateClaims ClaimObj++privateClaimsComplexTest :: Alg -> Spec+privateClaimsComplexTest alg =+ E.specify "private-claims-complex"+ $ mkTest+ Header { alg, typ = JWT }+ (JWT.ClaimsMap $ Map.fromList+ [ ("name" , JSON.String "John Doe")+ , ("userId", JSON.Number 12345)+ , ("role" , JSON.String "regularUser")+ ]+ )+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-private-claims-complex"+ )+ MkClaims { name = "John Doe"+ , userId = 12345+ , role = Flag RegularUser+ }++privateClaimsNsTest :: Alg -> Spec+privateClaimsNsTest alg =+ E.specify "private-claims-ns"+ $ mkTest+ Header { alg, typ = JWT }+ (JWT.ClaimsMap $ Map.fromList+ [ ("http://example.com/name" , JSON.String "John Doe")+ , ("http://example.com/userId" , JSON.Number 12345)+ , ("http://example.com/isAdmin", JSON.Bool False)+ ]+ )+ <$> jwtPayload+ ( withIssuer "libjwt-typed-test"+ <> withSubject "test-private-claims-ns"+ <> issuedNow+ <> notBeforeNow+ )+ (withNs+ (Ns @"http://example.com")+ ( #name ->> ("John Doe" :: String)+ , #userId ->> (12345 :: Int)+ , #isAdmin ->> False+ )+ )++utfTest :: Alg -> Spec+utfTest alg =+ E.specify "utf"+ $ mkTest+ Header { alg, typ = JWT }+ (JWT.ClaimsMap $ Map.fromList+ [("name", JSON.String "孔子"), ("status", JSON.String "不患人之不己知，患不知人也")]+ )+ <$> jwtPayload+ (withIssuer "libjwt-typed-test" <> withSubject "test-utf")+ (#name ->> ("孔子" :: String), #status ->> ("不患人之不己知，患不知人也" :: T.Text))++mkTest+ :: Encode (PrivateClaims cs ns)+ => Header+ -> JWT.ClaimsMap+ -> Payload cs ns+ -> Expectation+mkTest outHeader expected payload =+ let outJwt = Jwt { header = outHeader, payload }+ token = TE.decodeASCII $ getToken $ signJwt outJwt+ in expectDecodable token $ \unverifiedJwt -> do+ expectHeader outHeader $ JWT.header unverifiedJwt+ expectClaimsSet payload expected $ JWT.claims unverifiedJwt+ case mkSigner $ alg outHeader of+ Nothing -> pure ()+ Just signer ->+ maybe+ ( expectationFailure+ $ "Web.JWT: Unverifiable token\n"+ ++ show token+ ++ "\nheader:\n"+ ++ show outHeader+ )+ (const $ pure ())+ $ JWT.verify signer unverifiedJwt++expectDecodable+ :: T.Text -> (JWT.JWT JWT.UnverifiedJWT -> Expectation) -> Expectation+expectDecodable outToken testCase =+ maybe (expectationFailure $ "Web.JWT: Undecodable token\n" ++ show outToken)+ testCase+ $ JWT.decode outToken++expectHeader :: Header -> JWT.JOSEHeader -> Expectation+expectHeader expected got =+ got+ `shouldBe` JWT.JOSEHeader (typ' $ typ expected)+ Nothing+ (alg' $ alg expected)+ Nothing+ where+ typ' JWT = Just "JWT"+ typ' (Typ mbs) = TE.decodeUtf8 <$> mbs++ alg' (HS256 _) = Just JWT.HS256+ alg' (RS256 _) = Just JWT.RS256+ alg' _ = Nothing++expectClaimsSet+ :: Payload cs ns -> JWT.ClaimsMap -> JWT.JWTClaimsSet -> Expectation+expectClaimsSet expected expectedUnreg got =+ got+ `shouldBe` JWT.JWTClaimsSet (iss' $ iss expected)+ (sub' $ sub expected)+ (aud' $ aud expected)+ (exp' $ exp expected)+ (nbf' $ nbf expected)+ (iat' $ iat expected)+ (jti' $ jti expected)+ expectedUnreg+ where+ stringToStringOrURI s =+ fromMaybe (error $ "JWT.stringOrURI on " ++ show s)+ $ JWT.stringOrURI+ $ T.pack s++ numericDateToIntDate d =+ fromMaybe (error $ "JWT.numericDate on " ++ show d)+ $ JWT.numericDate+ $ toPOSIX d++ iss' (Iss ms) = stringToStringOrURI <$> ms++ sub' (Sub ms) = stringToStringOrURI <$> ms++ aud' (Aud []) = Nothing+ aud' (Aud xs) = Just $ Right $ map stringToStringOrURI xs++ exp' (Exp mnd) = numericDateToIntDate <$> mnd++ nbf' (Nbf mnd) = numericDateToIntDate <$> mnd++ iat' (Iat mnd) = numericDateToIntDate <$> mnd++ jti' (Jti muid) = stringToStringOrURI . UUID.toString <$> muid++
+ test/Interop/JWTHelpers.hs view
@@ -0,0 +1,33 @@+module Interop.JWTHelpers+ ( mkSigner+ , mkJWTAlgorithm+ )+where++import Web.Libjwt ( Alg(..)+ , RsaKeyPair(..)+ , Secret(..)+ )++import Data.Maybe ( fromMaybe )++import qualified Web.JWT as JWT++mkSigner :: Alg -> Maybe JWT.Signer+mkSigner (HS256 secret) = Just $ JWT.HMACSecret $ reveal secret+mkSigner (RS256 pem ) = Just $ mkRSAPrivateKey pem+mkSigner None = Nothing+mkSigner _ = error "Unsupported alg"++mkRSAPrivateKey :: RsaKeyPair -> JWT.Signer+mkRSAPrivateKey pem =+ JWT.RSAPrivateKey+ $ fromMaybe (error $ "JWT.readRsaSecret on\n" ++ show pem)+ $ JWT.readRsaSecret+ $ privKey pem++mkJWTAlgorithm :: Alg -> Maybe JWT.Algorithm+mkJWTAlgorithm None = Nothing+mkJWTAlgorithm (HS256 _) = Just JWT.HS256+mkJWTAlgorithm (RS256 _) = Just JWT.RS256+mkJWTAlgorithm _ = error "Unsupported algorithm"
+ test/Properties.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Properties+ ( spec+ )+where++import Web.Libjwt+import Generators+import Libjwt.Classes+import Libjwt.JsonByteString+import Libjwt.JwtValidation ( runValidation )+import Libjwt.NumericDate ( minusSeconds )++import Control.Arrow ( left )+import Control.Exception ( displayException )++import Control.Monad.Trans.Reader ( runReader )++import Data.Aeson ( FromJSON+ , ToJSON+ , encode+ , decode+ )++import Data.Default++import Data.Either.Validation as V++import Data.Functor ( (<&>) )+import Data.List.NonEmpty ( NonEmpty )++import Data.Time.Calendar ( Day )+import Data.Time.Clock ( UTCTime )++import Data.UUID ( UUID )++import GHC.Generics++import Test.Hspec+import Test.Hspec.QuickCheck ( modifyArgs+ , prop+ )++import Test.QuickCheck++import Test.QuickCheck.Instances ( )++import Prelude hiding ( exp )++spec :: Spec+spec = modifyArgs quickcheckArgs $ do+ prop "enc-dec-roundtrip-reg-only" prop_encode_decode_roundtrip_reg_only+ prop "enc-dec-roundtrip" prop_encode_decode_roundtrip+ prop "enc-dec-roundtrip-ns" prop_encode_decode_roundtrip_ns+ prop "enc-dec-roundtrip-comp" prop_encode_decode_rountrip_comp+ prop "enc-dec-roundtrip-aeson" prop_encode_decode_roundtrip_aeson+ prop "from-to-generic" prop_from_to_generic+ prop "validity" prop_validity+ where+ quickcheckArgs args = args { maxSuccess = 4000+ , maxDiscardRatio = 5+ , maxSize = maxSize args `div` 2+ , maxShrinks = 1000+ }++prop_encode_decode_roundtrip_poly+ :: (Decode (PrivateClaims pc ns), Encode (PrivateClaims pc ns), Show a, Eq a)+ => (Jwt pc ns -> a)+ -> (a -> Jwt pc ns)+ -> a+ -> Property+prop_encode_decode_roundtrip_poly project embed a =+ let jwt = embed a+ in left+ displayException+ ( decodeByteString (alg $ header jwt) (getToken $ signJwt jwt)+ <&> project+ . getDecoded+ )+ === pure a++prop_encode_decode_roundtrip_reg_only :: Jwt Empty 'NoNs -> Property+prop_encode_decode_roundtrip_reg_only = prop_encode_decode_roundtrip_poly id id++prop_encode_decode_roundtrip+ :: Jwt+ '["intField" ->> Int, "dateField" ->> UTCTime, "textField" ->> JwtText, "optField" ->> Maybe JwtString, "arrayField" ->> [JwtText], "nonEmptyField" ->> NonEmpty ASCII]+ 'NoNs+ -> Property+prop_encode_decode_roundtrip = prop_encode_decode_roundtrip_poly id id++prop_encode_decode_roundtrip_ns+ :: Jwt+ '["dayField" ->> Day, "arrayField" ->> [Int], "stringField" ->> JwtString]+ ( 'SomeNs "https://example.com")+ -> Property+prop_encode_decode_roundtrip_ns = prop_encode_decode_roundtrip_poly id id++prop_encode_decode_rountrip_comp+ :: Jwt+ '["user_name" ->> JwtText, "is_root" ->> Bool, "type" ->> Flag AccountType, "client_id" ->> UUID, "created" ->> UTCTime, "accounts" ->> NonEmpty (UUID, JwtText)]+ 'NoNs+ -> Property+prop_encode_decode_rountrip_comp = prop_encode_decode_roundtrip_poly id id++data AccountType = Regular | Pro | Admin+ deriving stock (Show, Eq, Generic)++instance AFlag AccountType++instance Arbitrary AccountType where+ arbitrary = elements [Regular, Pro, Admin]++data ClaimObj = MkClaimObj { userName :: JwtText, isRoot :: Bool, clientId :: UUID, createdAt :: UTCTime }+ deriving stock (Show, Eq, Generic)++instance ToPrivateClaims ClaimObj+instance FromPrivateClaims ClaimObj++instance Arbitrary ClaimObj where+ arbitrary =+ MkClaimObj <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++ shrink MkClaimObj { userName, isRoot, clientId, createdAt } =+ MkClaimObj+ <$> shrink userName+ <*> pure isRoot+ <*> shrink clientId+ <*> shrink createdAt++prop_from_to_generic :: ClaimObj -> Property+prop_from_to_generic claimObj = forAllBlind genHeader $ \header ->+ prop_encode_decode_roundtrip_poly+ (fromPrivateClaims . privateClaims . payload)+ (\claimObj' -> Jwt+ { header+ , payload = def { privateClaims = toPrivateClaims claimObj' }+ }+ )+ claimObj++data Account = MkAccount { account_name :: JwtText, account_id :: UUID }+ deriving stock (Show, Eq, Generic)++instance FromJSON Account+instance ToJSON Account++instance JwtRep JsonByteString Account where+ rep = Json . encode+ unRep = decode . toJson++instance JsonBuilder Account+instance JsonParser Account++instance Arbitrary Account where+ arbitrary = MkAccount <$> arbitrary <*> arbitrary+ shrink (MkAccount name id) = MkAccount <$> shrink name <*> shrink id++prop_encode_decode_roundtrip_aeson+ :: Jwt '["user_id" ->> Int, "accounts" ->> NonEmpty Account] 'NoNs+ -> Property+prop_encode_decode_roundtrip_aeson = prop_encode_decode_roundtrip_poly id id++prop_validity+ :: UTCTime -> ValidationSettings -> Payload Empty 'NoNs -> Property+prop_validity time settings@Settings { leeway, appName } payload@ClaimsSet { exp, nbf, aud = Aud rs }+ | now >= validFrom && now < validTo && appropriate+ = label "valid" $ classify triviallyValid "trivial" $ success validate+ | otherwise+ = label "invalid" $ failure validate+ where+ now = fromUTC time++ validFrom = case nbf of+ Nbf Nothing -> minBound+ Nbf (Just sth) -> sth `minusSeconds` leeway+ validTo = case exp of+ Exp Nothing -> maxBound+ Exp (Just sth) -> sth `plusSeconds` leeway++ appropriate = null rs || maybe False (`elem` rs) appName++ triviallyValid = exp == Exp Nothing && nbf == Nbf Nothing && null rs++ validate = runReader (runValidation settings mempty payload) time++ success (V.Success _) = property True+ success errors = counterexample (show errors) False++ failure (V.Failure _) = property True+ failure other = counterexample (show other) False++
+ test/Spec.hs view
@@ -0,0 +1,21 @@+module Main+ ( main+ , onlyProperties+ )+where++import Interop.JWTDecoding as JWTDecodingInterop+import Interop.JWTEncoding as JWTEncodingInterop+import Properties as Props++import Test.Hspec++main :: IO ()+main = hspec $ parallel $ do+ describe "Interop" $ do+ describe "JWT.encoding" JWTEncodingInterop.spec+ describe "JWT.decoding" JWTDecodingInterop.spec+ describe "Properties" Props.spec++onlyProperties :: IO ()+onlyProperties = hspec Props.spec