servant-oauth2-examples (empty) → 0.1.0.0
raw patch · 11 files changed
+1559/−0 lines, 11 filesdep +basedep +base64-bytestringdep +binary
Dependencies added: base, base64-bytestring, binary, bytestring, clientsession, cookie, hoauth2, http-types, mtl, servant, servant-blaze, servant-oauth2, servant-oauth2-examples, servant-server, shakespeare, text, tomland, unordered-containers, uri-bytestring, wai, wai-middleware-auth, warp
Files
- LICENSE +440/−0
- README.md +0/−0
- example-auth/Main.hs +6/−0
- example-auth/db.txt +2/−0
- example-cookies/Main.hs +6/−0
- example-simple/Main.hs +6/−0
- servant-oauth2-examples.cabal +201/−0
- src/Servant/OAuth2/Examples/Authorisation.hs +476/−0
- src/Servant/OAuth2/Examples/Config.hs +34/−0
- src/Servant/OAuth2/Examples/Cookies.hs +190/−0
- src/Servant/OAuth2/Examples/Simple.hs +198/−0
+ LICENSE view
@@ -0,0 +1,440 @@+HIPPOCRATIC LICENSE++Version 3.0, October 2021++https://firstdonoharm.dev/version/3/0/full.txt++TERMS AND CONDITIONS++TERMS AND CONDITIONS FOR USE, COPY, MODIFICATION, PREPARATION OF DERIVATIVE+WORK, REPRODUCTION, AND DISTRIBUTION:++1. DEFINITIONS:++This section defines certain terms used throughout this license agreement.++1.1. “License” means the terms and conditions, as stated herein, for use, copy,+modification, preparation of derivative work, reproduction, and distribution of+Software (as defined below).++1.2. “Licensor” means the copyright and/or patent owner or entity authorized by+the copyright and/or patent owner that is granting the License.++1.3. “Licensee” means the individual or entity exercising permissions granted by+this License, including the use, copy, modification, preparation of derivative+work, reproduction, and distribution of Software (as defined below).++1.4. “Software” means any copyrighted work, including but not limited to+software code, authored by Licensor and made available under this License.++1.5. “Supply Chain” means the sequence of processes involved in the production+and/or distribution of a commodity, good, or service offered by the Licensee.++1.6. “Supply Chain Impacted Party” or “Supply Chain Impacted Parties” means any+person(s) directly impacted by any of Licensee’s Supply Chain, including the+practices of all persons or entities within the Supply Chain prior to a good or+service reaching the Licensee.++1.7. “Duty of Care” is defined by its use in tort law, delict law, and/or+similar bodies of law closely related to tort and/or delict law, including+without limitation, a requirement to act with the watchfulness, attention,+caution, and prudence that a reasonable person in the same or similar+circumstances would use towards any Supply Chain Impacted Party.++1.8. “Worker” is defined to include any and all permanent, temporary, and agency+workers, as well as piece-rate, salaried, hourly paid, legal young (minors),+part-time, night, and migrant workers.++2. INTELLECTUAL PROPERTY GRANTS:++This section identifies intellectual property rights granted to a Licensee.++2.1. Grant of Copyright License: Subject to the terms and conditions of this+License, Licensor hereby grants to Licensee a worldwide, non-exclusive,+no-charge, royalty-free copyright license to use, copy, modify, prepare+derivative work, reproduce, or distribute the Software, Licensor authored+modified software, or other work derived from the Software.++2.2. Grant of Patent License: Subject to the terms and conditions of this+License, Licensor hereby grants Licensee a worldwide, non-exclusive, no-charge,+royalty-free patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer Software.++3. ETHICAL STANDARDS:++This section lists conditions the Licensee must comply with in order to have+rights under this License.++The rights granted to the Licensee by this License are expressly made subject to+the Licensee’s ongoing compliance with the following conditions:++ * 3.1. The Licensee SHALL NOT, whether directly or indirectly, through agents+ or assigns:+ + * 3.1.1. Infringe upon any person’s right to life or security of person,+ engage in extrajudicial killings, or commit murder, without lawful cause+ (See Article 3, United Nations Universal Declaration of Human Rights;+ Article 6, International Covenant on Civil and Political Rights)+ + * 3.1.2. Hold any person in slavery, servitude, or forced labor (See Article+ 4, United Nations Universal Declaration of Human Rights; Article 8,+ International Covenant on Civil and Political Rights);+ + * 3.1.3. Contribute to the institution of slavery, slave trading, forced+ labor, or unlawful child labor (See Article 4, United Nations Universal+ Declaration of Human Rights; Article 8, International Covenant on Civil and+ Political Rights);+ + * 3.1.4. Torture or subject any person to cruel, inhumane, or degrading+ treatment or punishment (See Article 5, United Nations Universal+ Declaration of Human Rights; Article 7, International Covenant on Civil and+ Political Rights);+ + * 3.1.5. Discriminate on the basis of sex, gender, sexual orientation, race,+ ethnicity, nationality, religion, caste, age, medical disability or+ impairment, and/or any other like circumstances (See Article 7, United+ Nations Universal Declaration of Human Rights; Article 2, International+ Covenant on Economic, Social and Cultural Rights; Article 26, International+ Covenant on Civil and Political Rights);+ + * 3.1.6. Prevent any person from exercising his/her/their right to seek an+ effective remedy by a competent court or national tribunal (including+ domestic judicial systems, international courts, arbitration bodies, and+ other adjudicating bodies) for actions violating the fundamental rights+ granted to him/her/them by applicable constitutions, applicable laws, or by+ this License (See Article 8, United Nations Universal Declaration of Human+ Rights; Articles 9 and 14, International Covenant on Civil and Political+ Rights);+ + * 3.1.7. Subject any person to arbitrary arrest, detention, or exile (See+ Article 9, United Nations Universal Declaration of Human Rights; Article 9,+ International Covenant on Civil and Political Rights);+ + * 3.1.8. Subject any person to arbitrary interference with a person’s+ privacy, family, home, or correspondence without the express written+ consent of the person (See Article 12, United Nations Universal Declaration+ of Human Rights; Article 17, International Covenant on Civil and Political+ Rights);+ + * 3.1.9. Arbitrarily deprive any person of his/her/their property (See+ Article 17, United Nations Universal Declaration of Human Rights);+ + * 3.1.10. Forcibly remove indigenous peoples from their lands or territories+ or take any action with the aim or effect of dispossessing indigenous+ peoples from their lands, territories, or resources, including without+ limitation the intellectual property or traditional knowledge of indigenous+ peoples, without the free, prior, and informed consent of indigenous+ peoples concerned (See Articles 8 and 10, United Nations Declaration on the+ Rights of Indigenous Peoples);+ + * 3.1.11. Fossil Fuel Divestment: Be an individual or entity, or a+ representative, agent, affiliate, successor, attorney, or assign of an+ individual or entity, on the FFI Solutions Carbon Underground 200 list+ [https://www.ffisolutions.com/research-analytics-index-solutions/research-screening/the-carbon-underground-200/?cn-reloaded=1];+ + * 3.1.12. Ecocide: Commit ecocide:+ + * 3.1.12.1. For the purpose of this section, “ecocide” means unlawful or+ wanton acts committed with knowledge that there is a substantial+ likelihood of severe and either widespread or long-term damage to the+ environment being caused by those acts;+ + * 3.1.12.2. For the purpose of further defining ecocide and the terms+ contained in the previous paragraph:+ + * 3.1.12.2.1. “Wanton” means with reckless disregard for damage which+ would be clearly excessive in relation to the social and economic+ benefits anticipated;+ + * 3.1.12.2.2. “Severe” means damage which involves very serious adverse+ changes, disruption, or harm to any element of the environment,+ including grave impacts on human life or natural, cultural, or+ economic resources;+ + * 3.1.12.2.3. “Widespread” means damage which extends beyond a limited+ geographic area, crosses state boundaries, or is suffered by an entire+ ecosystem or species or a large number of human beings;+ + * 3.1.12.2.4. “Long-term” means damage which is irreversible or which+ cannot be redressed through natural recovery within a reasonable+ period of time; and+ + * 3.1.12.2.5. “Environment” means the earth, its biosphere, cryosphere,+ lithosphere, hydrosphere, and atmosphere, as well as outer space+ + (See Section II, Independent Expert Panel for the Legal Definition of+ Ecocide, Stop Ecocide Foundation and the Promise Institute for Human+ Rights at UCLA School of Law, June 2021);+ + * 3.1.13. Extractive Industries: Be an individual or entity, or a+ representative, agent, affiliate, successor, attorney, or assign of an+ individual or entity, that engages in fossil fuel or mineral exploration,+ extraction, development, or sale;+ + * 3.1.14. Boycott / Divestment / Sanctions: Be an individual or entity, or a+ representative, agent, affiliate, successor, attorney, or assign of an+ individual or entity, identified by the Boycott, Divestment, Sanctions+ (“BDS”) movement on its website (https://bdsmovement.net/+ [https://bdsmovement.net/] and+ https://bdsmovement.net/get-involved/what-to-boycott+ [https://bdsmovement.net/get-involved/what-to-boycott]) as a target for+ boycott;+ + * 3.1.15. Taliban: Be an individual or entity that:+ + * 3.1.15.1. engages in any commercial transactions with the Taliban; or+ + * 3.1.15.2. is a representative, agent, affiliate, successor, attorney, or+ assign of the Taliban;+ + * 3.1.16. Myanmar: Be an individual or entity that:+ + * 3.1.16.1. engages in any commercial transactions with the+ Myanmar/Burmese military junta; or+ + * 3.1.16.2. is a representative, agent, affiliate, successor, attorney, or+ assign of the Myanmar/Burmese government;+ + * 3.1.17. Xinjiang Uygur Autonomous Region: Be an individual or entity, or a+ representative, agent, affiliate, successor, attorney, or assign of any+ individual or entity, that does business in, purchases goods from, or+ otherwise benefits from goods produced in the Xinjiang Uygur Autonomous+ Region of China;+ + * 3.1.18. US Tariff Act: Be an individual or entity:+ + * 3.1.18.1. which U.S. Customs and Border Protection (CBP) has currently+ issued a Withhold Release Order (WRO) or finding against based on+ reasonable suspicion of forced labor; or+ + * 3.1.18.2. that is a representative, agent, affiliate, successor,+ attorney, or assign of an individual or entity that does business with+ an individual or entity which currently has a WRO or finding from CBP+ issued against it based on reasonable suspicion of forced labor;+ + * 3.1.19. Mass Surveillance: Be a government agency or multinational+ corporation, or a representative, agent, affiliate, successor, attorney,+ or assign of a government or multinational corporation, which participates+ in mass surveillance programs;+ + * 3.1.20. Military Activities: Be an entity or a representative, agent,+ affiliate, successor, attorney, or assign of an entity which conducts+ military activities;+ + * 3.1.21. Law Enforcement: Be an individual or entity, or a or a+ representative, agent, affiliate, successor, attorney, or assign of an+ individual or entity, that provides good or services to, or otherwise+ enters into any commercial contracts with, any local, state, or federal+ law enforcement agency;+ + * 3.1.22. Media: Be an individual or entity, or a or a representative,+ agent, affiliate, successor, attorney, or assign of an individual or+ entity, that broadcasts messages promoting killing, torture, or other+ forms of extreme violence;+ + * 3.1.23. Interfere with Workers' free exercise of the right to organize and+ associate (See Article 20, United Nations Universal Declaration of Human+ Rights; C087 - Freedom of Association and Protection of the Right to+ Organise Convention, 1948 (No. 87), International Labour Organization;+ Article 8, International Covenant on Economic, Social and Cultural Rights);+ and+ + * 3.1.24. Harm the environment in a manner inconsistent with local, state,+ national, or international law.++ * 3.2. The Licensee SHALL:+ + * 3.2.1. Social Auditing: Only use social auditing mechanisms that adhere to+ Worker-Driven Social Responsibility Network’s Statement of Principles+ (https://wsr-network.org/what-is-wsr/statement-of-principles/+ [https://wsr-network.org/what-is-wsr/statement-of-principles/]) over+ traditional social auditing mechanisms, to the extent the Licensee uses+ any social auditing mechanisms at all;+ + * 3.2.2. Workers on Board of Directors: Ensure that if the Licensee has a+ Board of Directors, 30% of Licensee’s board seats are held by Workers paid+ no more than 200% of the compensation of the lowest paid Worker of the+ Licensee;+ + * 3.2.3. Supply Chain: Provide clear, accessible supply chain data to the+ public in accordance with the following conditions:+ + * 3.2.3.1. All data will be on Licensee’s website and/or, to the extent+ Licensee is a representative, agent, affiliate, successor, attorney,+ subsidiary, or assign, on Licensee’s principal’s or parent’s website or+ some other online platform accessible to the public via an internet+ search on a common internet search engine; and+ + * 3.2.3.2. Data published will include, where applicable, manufacturers,+ top tier suppliers, subcontractors, cooperatives, component parts+ producers, and farms;+ + * 3.2.4. Provide equal pay for equal work where the performance of such work+ requires equal skill, effort, and responsibility, and which are performed+ under similar working conditions, except where such payment is made+ pursuant to:+ + * 3.2.4.1. A seniority system;+ + * 3.2.4.2. A merit system;+ + * 3.2.4.3. A system which measures earnings by quantity or quality of+ production; or+ + * 3.2.4.4. A differential based on any other factor other than sex, gender,+ sexual orientation, race, ethnicity, nationality, religion, caste, age,+ medical disability or impairment, and/or any other like circumstances+ (See 29 U.S.C.A. § 206(d)(1); Article 23, United Nations Universal+ Declaration of Human Rights; Article 7, International Covenant on+ Economic, Social and Cultural Rights; Article 26, International Covenant+ on Civil and Political Rights); and+ + * 3.2.5. Allow for reasonable limitation of working hours and periodic+ holidays with pay (See Article 24, United Nations Universal Declaration of+ Human Rights; Article 7, International Covenant on Economic, Social and+ Cultural Rights).++4. SUPPLY CHAIN IMPACTED PARTIES:++This section identifies additional individuals or entities that a Licensee could+harm as a result of violating the Ethical Standards section, the condition that+the Licensee must voluntarily accept a Duty of Care for those individuals or+entities, and the right to a private right of action that those individuals or+entities possess as a result of violations of the Ethical Standards section.++4.1. In addition to the above Ethical Standards, Licensee voluntarily accepts a+Duty of Care for Supply Chain Impacted Parties of this License, including+individuals and communities impacted by violations of the Ethical Standards. The+Duty of Care is breached when a provision within the Ethical Standards section+is violated by a Licensee, one of its successors or assigns, or by an individual+or entity that exists within the Supply Chain prior to a good or service+reaching the Licensee.++4.2. Breaches of the Duty of Care, as stated within this section, shall create a+private right of action, allowing any Supply Chain Impacted Party harmed by the+Licensee to take legal action against the Licensee in accordance with applicable+negligence laws, whether they be in tort law, delict law, and/or similar bodies+of law closely related to tort and/or delict law, regardless if Licensee is+directly responsible for the harms suffered by a Supply Chain Impacted Party.+Nothing in this section shall be interpreted to include acts committed by+individuals outside of the scope of his/her/their employment.++5. NOTICE: This section explains when a Licensee must notify others of the+License.++5.1. Distribution of Notice: Licensee must ensure that everyone who receives a+copy of or uses any part of Software from Licensee, with or without changes,+also receives the License and the copyright notice included with Software (and+if included by the Licensor, patent, trademark, and attribution notice).+Licensee must ensure that License is prominently displayed so that any+individual or entity seeking to download, copy, use, or otherwise receive any+part of Software from Licensee is notified of this License and its terms and+conditions. Licensee must cause any modified versions of the Software to carry+prominent notices stating that Licensee changed the Software.++5.2. Modified Software: Licensee is free to create modifications of the Software+and distribute only the modified portion created by Licensee, however, any+derivative work stemming from the Software or its code must be distributed+pursuant to this License, including this Notice provision.++5.3. Recipients as Licensees: Any individual or entity that uses, copies,+modifies, reproduces, distributes, or prepares derivative work based upon the+Software, all or part of the Software’s code, or a derivative work developed by+using the Software, including a portion of its code, is a Licensee as defined+above and is subject to the terms and conditions of this License.++6. REPRESENTATIONS AND WARRANTIES:++6.1. Disclaimer of Warranty: TO THE FULL EXTENT ALLOWED BY LAW, THIS SOFTWARE+COMES “AS IS,” WITHOUT ANY WARRANTY, EXPRESS OR IMPLIED, AND LICENSOR SHALL NOT+BE LIABLE TO ANY PERSON OR ENTITY FOR ANY DAMAGES OR OTHER LIABILITY ARISING+FROM, OUT OF, OR IN CONNECTION WITH THE SOFTWARE OR THIS LICENSE, UNDER ANY+LEGAL CLAIM.++6.2. Limitation of Liability: LICENSEE SHALL HOLD LICENSOR HARMLESS AGAINST ANY+AND ALL CLAIMS, DEBTS, DUES, LIABILITIES, LIENS, CAUSES OF ACTION, DEMANDS,+OBLIGATIONS, DISPUTES, DAMAGES, LOSSES, EXPENSES, ATTORNEYS' FEES, COSTS,+LIABILITIES, AND ALL OTHER CLAIMS OF EVERY KIND AND NATURE WHATSOEVER, WHETHER+KNOWN OR UNKNOWN, ANTICIPATED OR UNANTICIPATED, FORESEEN OR UNFORESEEN, ACCRUED+OR UNACCRUED, DISCLOSED OR UNDISCLOSED, ARISING OUT OF OR RELATING TO LICENSEE’S+USE OF THE SOFTWARE. NOTHING IN THIS SECTION SHOULD BE INTERPRETED TO REQUIRE+LICENSEE TO INDEMNIFY LICENSOR, NOR REQUIRE LICENSOR TO INDEMNIFY LICENSEE.++7. TERMINATION++7.1. Violations of Ethical Standards or Breaching Duty of Care: If Licensee+violates the Ethical Standards section or Licensee, or any other person or+entity within the Supply Chain prior to a good or service reaching the Licensee,+breaches its Duty of Care to Supply Chain Impacted Parties, Licensee must remedy+the violation or harm caused by Licensee within 30 days of being notified of the+violation or harm. If Licensee fails to remedy the violation or harm within 30+days, all rights in the Software granted to Licensee by License will be null and+void as between Licensor and Licensee.++7.2. Failure of Notice: If any person or entity notifies Licensee in writing+that Licensee has not complied with the Notice section of this License, Licensee+can keep this License by taking all practical steps to comply within 30 days+after the notice of noncompliance. If Licensee does not do so, Licensee’s+License (and all rights licensed hereunder) will end immediately.++7.3. Judicial Findings: In the event Licensee is found by a civil, criminal,+administrative, or other court of competent jurisdiction, or some other+adjudicating body with legal authority, to have committed actions which are in+violation of the Ethical Standards or Supply Chain Impacted Party sections of+this License, all rights granted to Licensee by this License will terminate+immediately.++7.4. Patent Litigation: If Licensee institutes patent litigation against any+entity (including a cross-claim or counterclaim in a suit) alleging that the+Software, all or part of the Software’s code, or a derivative work developed+using the Software, including a portion of its code, constitutes direct or+contributory patent infringement, then any patent license, along with all other+rights, granted to Licensee under this License will terminate as of the date+such litigation is filed.++7.5. Additional Remedies: Termination of the License by failing to remedy harms+in no way prevents Licensor or Supply Chain Impacted Party from seeking+appropriate remedies at law or in equity.++8. MISCELLANEOUS:++8.1. Conditions: Sections 3, 4.1, 5.1, 5.2, 7.1, 7.2, 7.3, and 7.4 are+conditions of the rights granted to Licensee in the License.++8.2. Equitable Relief: Licensor and any Supply Chain Impacted Party shall be+entitled to equitable relief, including injunctive relief or specific+performance of the terms hereof, in addition to any other remedy to which they+are entitled at law or in equity.++8.3. Copyleft: Modified software, source code, or other derivative work must be+licensed, in its entirety, under the exact same conditions as this License.++8.4. Severability: If any term or provision of this License is determined to be+invalid, illegal, or unenforceable by a court of competent jurisdiction, any+such determination of invalidity, illegality, or unenforceability shall not+affect any other term or provision of this License or invalidate or render+unenforceable such term or provision in any other jurisdiction. If the+determination of invalidity, illegality, or unenforceability by a court of+competent jurisdiction pertains to the terms or provisions contained in the+Ethical Standards section of this License, all rights in the Software granted to+Licensee shall be deemed null and void as between Licensor and Licensee.++8.5. Section Titles: Section titles are solely written for organizational+purposes and should not be used to interpret the language within each section.++8.6. Citations: Citations are solely written to provide context for the source+of the provisions in the Ethical Standards.++8.7. Section Summaries: Some sections have a brief italicized description which+is provided for the sole purpose of briefly describing the section and should+not be used to interpret the terms of the License.++8.8. Entire License: This is the entire License between the Licensor and+Licensee with respect to the claims released herein and that the consideration+stated herein is the only consideration or compensation to be paid or exchanged+between them for this License. This License cannot be modified or amended except+in a writing signed by Licensor and Licensee.++8.9. Successors and Assigns: This License shall be binding upon and inure to the+benefit of the Licensor’s and Licensee’s respective heirs, successors, and+assigns.
+ README.md view
+ example-auth/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Servant.OAuth2.Examples.Authorisation qualified as Authorisation++main :: IO ()+main = Authorisation.main
+ example-auth/db.txt view
@@ -0,0 +1,2 @@+silky@users.noreply.github.com,admin+noon.vandersilk@tweag.io,user
+ example-cookies/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Servant.OAuth2.Examples.Cookies qualified as Cookies++main :: IO ()+main = Cookies.main
+ example-simple/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Servant.OAuth2.Examples.Simple qualified as Simple++main :: IO ()+main = Simple.main
+ servant-oauth2-examples.cabal view
@@ -0,0 +1,201 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: servant-oauth2-examples+version: 0.1.0.0+synopsis: Example applications using this library in three ways.+description: Three examples of using this library, either just to demonstrate the end-to-end connection ("Simple"), with cookies ("Cookies") or with type-level authorisation ("Authorised").+category: Web+homepage: https://github.com/tweag/servant-oauth2#readme+author: Tweag+maintainer: noon.vandersilk@tweag.io+copyright: 2022 Tweag+license: OtherLicense+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ example-auth/db.txt+ LICENSE++library+ exposed-modules:+ Servant.OAuth2.Examples.Authorisation+ Servant.OAuth2.Examples.Config+ Servant.OAuth2.Examples.Cookies+ Servant.OAuth2.Examples.Simple+ other-modules:+ Paths_servant_oauth2_examples+ hs-source-dirs:+ src+ default-extensions:+ DataKinds+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ ImportQualifiedPost+ KindSignatures+ OverloadedStrings+ PackageImports+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -W -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , binary+ , bytestring+ , clientsession+ , cookie+ , hoauth2+ , http-types+ , mtl+ , servant+ , servant-blaze+ , servant-oauth2+ , servant-server+ , shakespeare+ , text+ , tomland+ , unordered-containers+ , uri-bytestring+ , wai+ , wai-middleware-auth+ , warp+ default-language: Haskell2010++executable example-auth+ main-is: Main.hs+ other-modules:+ Paths_servant_oauth2_examples+ hs-source-dirs:+ example-auth+ default-extensions:+ DataKinds+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ ImportQualifiedPost+ KindSignatures+ OverloadedStrings+ PackageImports+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -W -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , binary+ , bytestring+ , clientsession+ , cookie+ , hoauth2+ , http-types+ , mtl+ , servant+ , servant-blaze+ , servant-oauth2+ , servant-oauth2-examples+ , servant-server+ , shakespeare+ , text+ , tomland+ , unordered-containers+ , uri-bytestring+ , wai+ , wai-middleware-auth+ , warp+ default-language: Haskell2010++executable example-cookies+ main-is: Main.hs+ other-modules:+ Paths_servant_oauth2_examples+ hs-source-dirs:+ example-cookies+ default-extensions:+ DataKinds+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ ImportQualifiedPost+ KindSignatures+ OverloadedStrings+ PackageImports+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -W -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , binary+ , bytestring+ , clientsession+ , cookie+ , hoauth2+ , http-types+ , mtl+ , servant+ , servant-blaze+ , servant-oauth2+ , servant-oauth2-examples+ , servant-server+ , shakespeare+ , text+ , tomland+ , unordered-containers+ , uri-bytestring+ , wai+ , wai-middleware-auth+ , warp+ default-language: Haskell2010++executable example-simple+ main-is: Main.hs+ other-modules:+ Paths_servant_oauth2_examples+ hs-source-dirs:+ example-simple+ default-extensions:+ DataKinds+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ ImportQualifiedPost+ KindSignatures+ OverloadedStrings+ PackageImports+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -W -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , binary+ , bytestring+ , clientsession+ , cookie+ , hoauth2+ , http-types+ , mtl+ , servant+ , servant-blaze+ , servant-oauth2+ , servant-oauth2-examples+ , servant-server+ , shakespeare+ , text+ , tomland+ , unordered-containers+ , uri-bytestring+ , wai+ , wai-middleware-auth+ , warp+ default-language: Haskell2010
+ src/Servant/OAuth2/Examples/Authorisation.hs view
@@ -0,0 +1,476 @@+{-# language NamedFieldPuns #-}+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}+{-# language TypeFamilies #-}++{-|++This is the last example we provide, but also the most interesting, and,+indeed, the main motivation for this libraries existence!++Here we show how to build type-level authorisation into your Servant API,+backed by authentication with OAuth2.++We assume you've read over the previous two examples, as we build directly+on that knowledge:++- "Servant.OAuth2.Examples.Simple"+- "Servant.OAuth2.Examples.Cookies"++-}++module Servant.OAuth2.Examples.Authorisation where++import "mtl" Control.Monad.Reader (ReaderT, ask, runReaderT, withReaderT)+import "base" Data.Coerce (coerce)+import "unordered-containers" Data.HashMap.Strict qualified as H+import "base" Data.Maybe (fromJust, isJust)+import "text" Data.Text (Text)+import "text" Data.Text qualified as Text+import "text" Data.Text.Encoding (decodeUtf8)+import "text" Data.Text.IO qualified as Text+import "base" GHC.Generics (Generic)+import "wai" Network.Wai (Request)+import "warp" Network.Wai.Handler.Warp (run)+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Github+ ( Github (..)+ , mkGithubProvider+ )+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Google+ ( Google (..)+ , mkGoogleProvider+ )+import "servant-server" Servant+ ( AuthProtect+ , Context (EmptyContext, (:.))+ , Get+ , Handler+ , NamedRoutes+ , Proxy (Proxy)+ , ServerT+ , StdMethod (GET)+ , UVerb+ , WithStatus (WithStatus)+ , err404+ , hoistServer+ , respond+ , throwError+ , type (:>)+ )+import "servant" Servant.API.Generic ((:-))+import "servant-blaze" Servant.HTML.Blaze (HTML)+import Servant.OAuth2+import Servant.OAuth2.Cookies+import Servant.OAuth2.Examples.Config+import Servant.OAuth2.Hacks+import "servant-server" Servant.Server.Experimental.Auth+ ( AuthHandler+ , AuthServerData+ , mkAuthHandler+ )+import "servant-server" Servant.Server.Generic+ ( AsServerT+ , genericServeTWithContext+ )+import "shakespeare" Text.Hamlet (Html, shamlet)+import "tomland" Toml (decodeFileExact)+import "clientsession" Web.ClientSession (Key, getDefaultKey)+++-- | This time we're going to have users. We're keeping it light and easy+-- here, so our /database/ is simply a map of emails to users. At this point+-- I'd like to note a slight quirk of oauth2-based authentication.+--+-- Note that the ident that comes back from the provider is up to that+-- provider itself. So, for example, I could make an entirely new oauth2+-- provider that always returns the same email, for example. In particular, it+-- could always return _you_ email. Then, if this website added my (dodgey)+-- provider to it's list, I would be able to log in as you, if all you to do+-- verify accounts is /look up the user by the email/. So, in any real system,+-- you should track the /provider name/ along side the user ident, and only+-- use /that/ combination to find users. We don't do that here, but it's worth+-- remembering.+--+-- @since 0.1.0.0+type Db = H.HashMap Text User+++-- | We will use this type to tag particular routes as being only accessible+-- to users with the 'Admin' role, or, alternatively, /everyone/, i.e. those+-- people having the 'Anyone' role ... namely, everyone!+--+-- @since 0.1.0.0+data Role = Anyone | Admin+++-- | Our user type that lives in the database. Importantly, this holds the+-- 'role', which we will check when it comes to verifying if a particular+-- person can access the 'Admin' route.+--+-- @since 0.1.0.0+data User = User+ { email :: Text+ , role :: Text+ }+ deriving stock (Show)+++-- | This is a collection of data that we'll want to have available during+-- page processing; so we will wrap the servant 'Handler' type with a+-- 'ReaderT' over this type.+--+-- @since 0.1.0.0+data Env (r :: Role) = Env+ { user :: Maybe User+ , githubSettings :: OAuth2Settings PageM Github OAuth2Result+ , githubOAuthConfig :: OAuthConfig+ , googleSettings :: OAuth2Settings PageM Google OAuth2Result+ , googleOAuthConfig :: OAuthConfig+ }+++-- | Our type-level authorisation system. We tag two kinds of /page monads/;+-- one that works for 'Anyone'; this one.+--+-- @since 0.1.0.0+type PageM = ReaderT (Env 'Anyone) Handler+++-- | And this one, that is specialised to 'Admin' users. If we make a mistake,+-- we will get a type error along the lines of @Cannot match 'Admin with+-- 'Anyone@.+--+-- @since 0.1.0.0+type AdminPageM = ReaderT (Env 'Admin) Handler+++-- | As in the "Servant.OAuth2.Examples.Cookies" example, our result type is+-- just a redirection with a cookie.+--+-- @since 0.1.0.0+type OAuth2Result = '[WithStatus 303 RedirectWithCookie]+++-- | Again, we exactly follow the "Servant.OAuth2.Examples.Cookies" example.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result+++-- | Same here.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect Google) = Tag Google OAuth2Result+++-- | The only difference here is the return a 'User' instead of 'Text'.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect "optional-cookie") = Maybe User+++-- | This is almost identical to the "Servant.OAuth2.Examples.Cookies"+-- example, except we look up the user in the database, and if we find it, we+-- return it.+--+-- @since 0.1.0.0+optionalUserAuthHandler :: Db -> Key -> AuthHandler Request (Maybe User)+optionalUserAuthHandler db key = mkAuthHandler f+ where+ f :: Request -> Handler (Maybe User)+ f req = do+ let sessionId = getSessionIdFromCookie req key+ -- Here, we know the sessionId is, infact, the email address of the user.+ -- So, we can just look it up in the database.+ pure $ maybe Nothing (flip H.lookup db . decodeUtf8) sessionId+++-- | This follows exactly the "Servant.OAuth2.Examples.Cookies" example; we're+-- using two providers because in the hard-coded `db.txt` file I've set+-- different roles for my own account with different providers; you'll be able+-- to edit that file to do the same.+--+-- @since 0.1.0.0+data Routes mode = Routes+ { site :: mode :- AuthProtect "optional-cookie" :> NamedRoutes (SiteRoutes)+ , authGithub ::+ mode+ :- AuthProtect Github+ :> "auth"+ :> "github"+ :> NamedRoutes (OAuth2Routes OAuth2Result)+ , authGoogle ::+ mode+ :- AuthProtect Google+ :> "auth"+ :> "google"+ :> NamedRoutes (OAuth2Routes OAuth2Result)+ }+ deriving stock (Generic)+++-- | We now have a slightly more complicated route setup; we need our+-- homepage, and our admin area, which we will aim to protect with our+-- type-level tags; we also need a 'logout' route, because it'll be convenient+-- for testing. This route will simply delete the present cookie.+--+-- @since 0.1.0.0+data SiteRoutes mode = SiteRoutes+ { home :: mode :- Get '[HTML] Html+ , admin :: mode :- "admin" :> NamedRoutes AdminRoutes+ , logout :: mode :- "logout" :> UVerb 'GET '[HTML] '[WithStatus 303 RedirectWithCookie]+ }+ deriving stock (Generic)+++-- | Nothing too innovative; we just pass off to respective handlers and+-- servers; in the 'logout' route we set an empty cookie and redirect home.+--+-- @since 0.1.0.0+siteServer :: SiteRoutes (AsServerT PageM)+siteServer = SiteRoutes+ { home = homeHandler+ , admin = adminServer+ , logout = respond $ WithStatus @303 (redirectWithCookie "/" emptyCookie)+ }+++-- | Our admin routes. At this point they look normal.+--+-- @since 0.1.0.0+data AdminRoutes mode = AdminRoutes+ { adminHome :: mode :- Get '[HTML] Html+ }+ deriving stock (Generic)+++-- | Here is where we introduce the 'AdminPageM' type. Typically, a handler+-- like this would have type 'Handler'; but here we're denoting it as having+-- the 'AdminPageM' type. This means we can call specific functions, that we+-- will define below, such as 'getAdmin'. Importantly, we will see that we+-- need to unwrap this type (by verifying the current user!) before we can+-- render this page.+--+-- @since 0.1.0.0+adminHandler :: AdminPageM Html+adminHandler = do+ let secrets =+ [ "secret 1" :: Text+ , "mundane secret 2"+ , "you can't know this"+ ]+ u <- getAdmin+ pure $+ [shamlet|+ <h3> Admin+ <p> Secrets:++ <ul>+ $forall secret <- secrets+ <li> #{secret}++ <p> Hello Admin person whose identity is: #{show u}.+ |]+++-- | Here's the most important function. We aim to convert 'AdminPageM's into+-- 'PageM's. We do this in the context of an 'PageM' function, where we+-- investigate the current user. If that user is an admin (vi a'isAdmin') then+-- we convert the given 'AdminPageM' into a 'PageM' by simply 'coerce'ing it;+-- after all, the 'Role' type was just a phantom type.+--+-- If we fail to verify that they are an admin, we throw a http 404 error.+--+-- @since 0.1.0.0+verifyAdmin :: ServerT (NamedRoutes AdminRoutes) AdminPageM+ -> ServerT (NamedRoutes AdminRoutes) PageM+verifyAdmin = hoistServer (Proxy @(NamedRoutes AdminRoutes)) transform+ where+ transform :: AdminPageM a -> PageM a+ transform p = do+ env <- ask+ let currentUser = user env+ if isAdmin currentUser+ then coerce p+ else throwError err404+++-- | Note here that this function returns a server of 'PageM's; that's because+-- we pass the routes through the 'verifyAdmin' function.+--+-- @since 0.1.0.0+adminServer :: ServerT (NamedRoutes AdminRoutes) PageM+adminServer = verifyAdmin $ AdminRoutes+ { adminHome = adminHandler+ }+++-- | A simple check to see if the user is present and has a 'role' that is+-- equal to `"admin"`.+--+-- @since 0.1.0.0+isAdmin :: Maybe User -> Bool+isAdmin (Just (User {role})) = role == "admin"+isAdmin _ = False+++-- | Check if a user is present and therefore logged in.+--+-- @since 0.1.0.0+isLoggedIn :: PageM Bool+isLoggedIn = pure . isJust . user =<< ask+++-- | In the context of a 'PageM', maybe return the user; this is the best we+-- can do.+--+-- @since 0.1.0.0+getUser :: PageM (Maybe User)+getUser = pure . user =<< ask+++-- | In the present of an 'AdminPageM', /definitely/ return a user. We're+-- happy with an error if this fails, because we know that a user needs to be+-- present.+--+-- Note that it could be an extension to this code to eliminate the 'fromJust'+-- here, and ensure that whatever context we're referencing has eliminated the+-- 'Maybe' over the user.+--+-- We leave this as an exercise for the reader :)+--+-- @since 0.1.0.0+getAdmin :: AdminPageM User+getAdmin = pure . fromJust . user =<< ask+++-- | This time our home handler does a bit of busywork to show whether or not+-- you're logged in, and provide the relevant links. It also detects if you're+-- an admin, and if not, provides you a link to the admin page anyway, to see+-- if you can hack into it! :)+--+-- @since 0.1.0.0+homeHandler :: PageM Html+homeHandler = do+ env <- ask++ let githubCallbackUrl = _callbackUrl $ githubOAuthConfig env+ githubLoginUrl = getGithubLoginUrl githubCallbackUrl (githubSettings env)++ let googleCallbackUrl = _callbackUrl $ googleOAuthConfig env+ googleLoginUrl = getGoogleLoginUrl googleCallbackUrl (googleSettings env)++ loggedIn <- isLoggedIn+ u <- getUser+ pure $+ [shamlet|+ <h3> Home - Example with authorisation++ $if not loggedIn+ <p>+ <a href="#{githubLoginUrl}"> Login with Github+ <br>+ <a href="#{googleLoginUrl}"> Login with Google+ $else+ Welcome #{show u}!+ <p>+ <a href="/logout"> Logout++ $if isAdmin u+ <p>+ <a href="/admin"> Access the admin area!+ $else+ <p>+ You're not an admin, but perhaps you may like to+ <a href="/admin"> try and hack into the admin area!+ |]+++-- | The final full server; we need a special 'hoistServer' for the 'site'+-- route, because we need to add the 'Maybe User' into the 'Env'. Otherwise,+-- we just do as we've always done - pass off to the 'authServer'.+--+-- @since 0.1.0.0+server :: Routes (AsServerT PageM)+server =+ Routes+ { site = \user ->+ let addUser env = env { user = user }+ in hoistServer+ (Proxy @(NamedRoutes SiteRoutes))+ (withReaderT addUser)+ siteServer+ , authGithub = authServer+ , authGoogle = authServer+ }+++-- | Our usual approach for 'Github' settings.+--+-- @since 0.1.0.0+mkGithubSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Github OAuth2Result+mkGithubSettings key c = settings+ where+ toSessionId _ = pure . id+ provider = mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing+ settings = simpleCookieOAuth2Settings provider toSessionId key+ emailAllowList = [".*"]+++-- | Our usual approach for 'Google' settings.+--+-- @since 0.1.0.0+mkGoogleSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Google OAuth2Result+mkGoogleSettings key c = settings+ where+ toSessionId _ = pure . id+ provider = mkGoogleProvider (_id c) (_secret c) emailAllowList Nothing+ settings = simpleCookieOAuth2Settings provider toSessionId key+ emailAllowList = [".*"]+++-- | Our usual approach to the 'main' function; setting up the settings,+-- setting up the contexts for the relevant auth handler functions.+--+-- @since 0.1.0.0+main :: IO ()+main = do+ eitherConfig <- decodeFileExact configCodec ("./config.toml")+ config <-+ either+ (\errors -> fail $ "unable to parse configuration: " <> show errors)+ pure+ eitherConfig++ key <- getDefaultKey+ db <- loadDb++ let nat :: PageM a -> Handler a+ nat = flip runReaderT env+ githubSettings = mkGithubSettings key (_githubOAuth config)+ googleSettings = mkGoogleSettings key (_googleOAuth config)+ env = Env Nothing+ githubSettings (_githubOAuth config)+ googleSettings (_googleOAuth config)+ context+ = optionalUserAuthHandler db key+ :. oauth2AuthHandler githubSettings nat+ :. oauth2AuthHandler googleSettings nat+ :. EmptyContext+++ putStrLn "Waiting for connections!"+ run 8080 $+ genericServeTWithContext nat server context+++-- | Utility function to load the hard-coded database.+--+-- @since 0.1.0.0+loadDb :: IO Db+loadDb = do+ ls <- Text.lines <$> Text.readFile "./servant-oauth2-examples/example-auth/db.txt"+ let raw = map (Text.split (==',')) ls+ mkRow [u,r] = (u, User u r)+ mkRow _ = error "Inconsistent database state."+ pure $ H.fromList $ map mkRow raw
+ src/Servant/OAuth2/Examples/Config.hs view
@@ -0,0 +1,34 @@+module Servant.OAuth2.Examples.Config where++import "text" Data.Text (Text)+import "tomland" Toml (TomlCodec, diwrap, table, text, (.=))+++data OAuthConfig = OAuthConfig+ { _name :: Text+ , _id :: Text+ , _secret :: Text+ , _callbackUrl :: Text+ }+++oauthConfigCodec :: TomlCodec OAuthConfig+oauthConfigCodec =+ OAuthConfig+ <$> diwrap (text "name") .= _name+ <*> diwrap (text "id") .= _id+ <*> diwrap (text "secret") .= _secret+ <*> diwrap (text "callback_url") .= _callbackUrl+++data Config = Config+ { _githubOAuth :: OAuthConfig+ , _googleOAuth :: OAuthConfig+ }+++configCodec :: TomlCodec Config+configCodec =+ Config+ <$> table oauthConfigCodec "oauth-github" .= _githubOAuth+ <*> table oauthConfigCodec "oauth-google" .= _googleOAuth
+ src/Servant/OAuth2/Examples/Cookies.hs view
@@ -0,0 +1,190 @@+{-# language NamedFieldPuns #-}+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}+{-# language TypeFamilies #-}++{-|++This example follows the "Servant.OAuth2.Examples.Simple" example very+closely, but this time we use a configuration that let's enables us to+set a cookie, and then redirect to the homepage.++Moreover, we set things up so that we can /read/ that cookie on /any/ page, to+determine if the current visitor is logged in.++We will assume you have read the "Simple" example, and mostly spend our time+explaining what is different.++-}++module Servant.OAuth2.Examples.Cookies where++import "base" Data.Maybe (fromJust, isJust)+import "text" Data.Text (Text)+import "base" GHC.Generics (Generic)+import "wai" Network.Wai (Request)+import "warp" Network.Wai.Handler.Warp (run)+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Github+ ( Github (..)+ , mkGithubProvider+ )+import "servant-server" Servant+ ( AuthProtect+ , Context (EmptyContext, (:.))+ , Get+ , Handler+ , NamedRoutes+ , WithStatus+ , type (:>)+ )+import "servant" Servant.API.Generic ((:-))+import "servant-blaze" Servant.HTML.Blaze (HTML)+import Servant.OAuth2+import Servant.OAuth2.Cookies+import Servant.OAuth2.Examples.Config+import Servant.OAuth2.Hacks+import "servant-server" Servant.Server.Experimental.Auth+ ( AuthHandler+ , AuthServerData+ , mkAuthHandler+ )+import "servant-server" Servant.Server.Generic+ ( AsServerT+ , genericServeTWithContext+ )+import "shakespeare" Text.Hamlet (Html, shamlet)+import "tomland" Toml (decodeFileExact)+import "clientsession" Web.ClientSession (Key, getDefaultKey)+++-- | This time our result type is a set of headers that both redirects, and+-- sets a particular cookie value. The cookie will, here, contain simply the+-- result of the oauth2 workflow; i.e. the users email.+--+-- @since 0.1.0.0+type OAuth2Result = '[WithStatus 303 RedirectWithCookie]+++-- | Our instance here is exactly the same (in fact, it will _always_ be the+-- same!); it just connects the 'Github' type and the 'OAuth2Result' type, so+-- it can be picked out by the right version of 'oauth2AuthHandler'.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result+++-- | Now, we want to be able to check if a user is logged in on any page. We+-- will use this 'AuthProtect' instance to do that.+--+-- The _result_ of this particular check could typically be some kind of+-- @User@ value, but here, we're not concerning ourselves with that detail, so+-- we will just return a 'Maybe Text'; i.e. either 'Nothing', if we couldn't+-- decode a user from the cookie, or the ident of the user if we could.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect "optional-cookie") = Maybe Text+++-- | This is the corresponding handler for the above instance. Our+-- implementation is very simple, we just call 'getSessionIdFromCookie', which+-- is provided by the "Servant.OAuth2" library itself; this decodes a+-- previously-encoded value from the cookie, by the corresponding function+-- 'buildSessionCookie', which we will later use through the+-- 'simpleCookieOAuth2Settings' function.+--+-- @since 0.1.0.0+optionalUserAuthHandler :: Key -> AuthHandler Request (Maybe Text)+optionalUserAuthHandler key = mkAuthHandler f+ where+ f :: Request -> Handler (Maybe Text)+ f req = do+ let sessionId = getSessionIdFromCookie req key+ pure sessionId+++-- | As last time, we have our routes; the main change is the inclusion of the+-- 'AuthProtect' tag on the 'home' route, that let's us bring a potential user+-- into scope for that page.+--+-- @since 0.1.0.0+data Routes mode = Routes+ { home :: mode :- AuthProtect "optional-cookie" :> Get '[HTML] Html+ , auth ::+ mode+ :- AuthProtect Github+ :> "auth"+ :> "github"+ :> NamedRoutes (OAuth2Routes OAuth2Result)+ }+ deriving stock (Generic)+++-- | Again, we have settings, but this time, instead of using the+-- 'defaultOAuth2Settings', we use the 'simpleCookieOAuth2Settings' function+-- to get default behaviour that, upon successful completion of the oauth2+-- flow, builds a cookie with a /session id/ — in this case just the+-- ident of the user — and then redirects the browser to the homepage.+--+-- @since 0.1.0.0+mkSettings :: Key -> OAuthConfig -> OAuth2Settings Handler Github OAuth2Result+mkSettings key c = settings+ where+ toSessionId _ = pure . id+ provider = mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing+ settings = simpleCookieOAuth2Settings provider toSessionId key+ emailAllowList = [".*"]+++-- | Now we can have a simple server implementation, but this time we can+-- check if the user us logged in by looking at the first parameter to the+-- 'home' function; i.e. if it's 'Nothing' then we're not logged in, otherwise+-- we are! Very convenient.+--+-- @since 0.1.0.0+server :: OAuthConfig+ -> OAuth2Settings Handler Github OAuth2Result+ -> Routes (AsServerT Handler)+server OAuthConfig {_callbackUrl} settings =+ Routes+ { home = \user -> do+ let githubLoginUrl = getGithubLoginUrl _callbackUrl settings+ loggedIn = isJust user+ pure $+ [shamlet|+ <h3> Home - Example with Cookies+ <p>+ $if not loggedIn+ <a href="#{githubLoginUrl}"> Login+ $else+ Welcome #{fromJust user}!+ |]+ , auth = authServer+ }+++-- | Our entrypoint; the only addition here is that we need to obtain a 'Key'+-- to do our cookie encryption/decryption; and we again need to build up our+-- context with our 'Github'-based 'oauth2AuthHandler' and our own custom one,+-- 'optionalUserAuthHandler', to decode the cookie.+--+-- @since 0.1.0.0+main :: IO ()+main = do+ eitherConfig <- decodeFileExact configCodec ("./config.toml")+ config <-+ either+ (\errors -> fail $ "unable to parse configuration: " <> show errors)+ pure+ eitherConfig++ key <- getDefaultKey++ let ghSettings = mkSettings key (_githubOAuth config)+ context = optionalUserAuthHandler key+ :. oauth2AuthHandler ghSettings nat+ :. EmptyContext+ nat = id++ putStrLn "Waiting for connections!"+ run 8080 $+ genericServeTWithContext nat (server (_githubOAuth config) ghSettings) context
+ src/Servant/OAuth2/Examples/Simple.hs view
@@ -0,0 +1,198 @@+{-# language NamedFieldPuns #-}+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}+{-# language TypeFamilies #-}+{-|++This is the simplest example of a full application that makes use of this+library.++We don't do anything with the result of successful authentication other than+return the ident that was provided to us. In an "real" example, you'll want to+set a cookie. For that, you can take a look at+"Servant.OAuth2.Examples.Cookies".++This file serves as a complete example; and you can read through this+documentation from top to bottom, in order to work out what each component is.+-}++module Servant.OAuth2.Examples.Simple where++import "text" Data.Text (Text)+import "base" GHC.Generics (Generic)+import "warp" Network.Wai.Handler.Warp (run)+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Github+ ( Github (..)+ , mkGithubProvider+ )+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Google+ ( Google (..)+ , mkGoogleProvider+ )+import "servant-server" Servant+ ( AuthProtect+ , Context (EmptyContext, (:.))+ , Get+ , Handler+ , NamedRoutes+ , WithStatus+ , type (:>)+ )+import "servant" Servant.API.Generic ((:-))+import "servant-blaze" Servant.HTML.Blaze (HTML)+import Servant.OAuth2+import Servant.OAuth2.Examples.Config+import Servant.OAuth2.Hacks+import "servant-server" Servant.Server.Experimental.Auth+ ( AuthServerData+ )+import "servant-server" Servant.Server.Generic+ ( AsServerT+ , genericServeTWithContext+ )+import "shakespeare" Text.Hamlet (Html, shamlet)+import "tomland" Toml (decodeFileExact)+++-- | First, we need to define an instance that corresponds to the result we+-- want to return. We're going with the 'basic' option; so we'll just take the+-- Text value of the ident that comes back. Note that this is a _list_ of+-- potential return kinds; the reason it's set up this way is only so we can+-- explicitly say we'd like to return a 303 Redirect, when using cookies.+--+-- @since 0.1.0.0+type OAuth2Result = '[WithStatus 200 Text]+++-- | Next up, we follow the approach of the generalised servant authentication+-- to connect up our (future usage of) the 'oauth2AuthHandler' to the+-- respective tagged routes by by this particular 'AuthProtect' instance,+-- namely, the 'authGithub' and 'authGoogle' routes we will define in a+-- moment.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result+++-- | Same as above, but for google.+--+-- @since 0.1.0.0+type instance AuthServerData (AuthProtect Google) = Tag Google OAuth2Result+++-- | Here we just define a very simple website, something like:+--+-- @+-- \/+-- \/auth\/github\/...+-- \/auth\/google\/...+-- @+--+-- The 'authGoogle' and 'authGithub' routes will not be implemented by us;+-- they are both provided by a 'NamedRoutes (OAuth2Routes OAuth2Result)'+-- value; i.e. the routes themselves come from 'Servant.OAuth2'.+--+-- @since 0.1.0.0+data Routes mode = Routes+ { home :: mode :- Get '[HTML] Html+ , authGithub ::+ mode+ :- AuthProtect Github+ :> "auth"+ :> "github"+ :> NamedRoutes (OAuth2Routes OAuth2Result)+ , authGoogle ::+ mode+ :- AuthProtect Google+ :> "auth"+ :> "google"+ :> NamedRoutes (OAuth2Routes OAuth2Result)+ }+ deriving stock (Generic)+++-- | We need to build an 'OAuth2Settings' to pass to 'oauth2AuthHandler', so+-- that it knows which provider it is working with. We also need to tag it+-- with a 'Handler'-like monad that can interpret errors; in the simple case+-- this is just the 'Handler' type itself, but in later examples (in+-- particular the "Servant.OAuth2.Examples.Authorisation" example) it will be+-- a custom monad.+--+-- @since 0.1.0.0+mkGithubSettings :: OAuthConfig -> OAuth2Settings Handler Github OAuth2Result+mkGithubSettings c =+ defaultOAuth2Settings $+ mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing+ where+ emailAllowList = [".*"]+++-- | Exactly the same as 'mkGithubSettings' but for the 'Google' provider.+--+-- @since 0.1.0.0+mkGoogleSettings :: OAuthConfig -> OAuth2Settings Handler Google OAuth2Result+mkGoogleSettings c =+ defaultOAuth2Settings $+ mkGoogleProvider (_id c) (_secret c) emailAllowList Nothing+ where+ emailAllowList = [".*"]+++-- | Here we pull implement a very simple homepage, basically just showing the+-- links to login, and connecting the two 'authGithub' and 'authGoogle' routes+-- together. There's a bit of noise in passing all the relevant configs in,+-- but this would go away in a "real" application, by passing that around in+-- an env, or otherwise.+--+-- @since 0.1.0.0+server ::+ Text ->+ OAuth2Settings Handler Github OAuth2Result ->+ Text ->+ OAuth2Settings Handler Google OAuth2Result ->+ Routes (AsServerT Handler)+server githubCallbackUrl githubSettings googleCallbackUrl googleSettings =+ Routes+ { home = do+ let githubLoginUrl = getGithubLoginUrl githubCallbackUrl githubSettings+ googleLoginUrl = getGoogleLoginUrl googleCallbackUrl googleSettings++ pure $+ [shamlet|+ <h3> Home - Basic Example+ <p>+ <a href="#{githubLoginUrl}"> Github Login+ <p>+ <a href="#{googleLoginUrl}"> Google Login+ |]+ , authGithub = authServer+ , authGoogle = authServer+ }+++-- | Entrypoint. The most important thing we do here is build our list of+-- contexts by calling 'oauth2AuthHandler' with the respective settings.+--+-- @since 0.1.0.0+main :: IO ()+main = do+ eitherConfig <- decodeFileExact configCodec ("./config.toml")+ config <-+ either+ (\errors -> fail $ "unable to parse configuration: " <> show errors)+ pure+ eitherConfig++ let githubSettings = mkGithubSettings (_githubOAuth config)+ googleSettings = mkGoogleSettings (_googleOAuth config)+ context = oauth2AuthHandler githubSettings nat+ :. oauth2AuthHandler googleSettings nat+ :. EmptyContext+ nat = id+ server' = server (_callbackUrl (_githubOAuth config))+ githubSettings+ (_callbackUrl (_googleOAuth config))+ googleSettings++ putStrLn "Waiting for connections!"+ run 8080 $ genericServeTWithContext nat server' context