├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── README.md ├── RELEASE.md ├── cabal.project ├── servant-auth-client ├── .ghci ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── servant-auth-client.cabal ├── src │ └── Servant │ │ └── Auth │ │ ├── Client.hs │ │ └── Client │ │ └── Internal.hs └── test │ ├── Servant │ └── Auth │ │ └── ClientSpec.hs │ └── Spec.hs ├── servant-auth-docs ├── .ghci ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── servant-auth-docs.cabal ├── src │ └── Servant │ │ └── Auth │ │ └── Docs.hs └── test │ ├── Spec.hs │ └── doctests.hs ├── servant-auth-server ├── .ghci ├── CHANGELOG.md ├── LICENSE ├── README.lhs ├── README.md ├── Setup.hs ├── servant-auth-server.cabal ├── src │ └── Servant │ │ └── Auth │ │ ├── Server.hs │ │ └── Server │ │ ├── Internal.hs │ │ ├── Internal │ │ ├── AddSetCookie.hs │ │ ├── BasicAuth.hs │ │ ├── Class.hs │ │ ├── ConfigTypes.hs │ │ ├── Cookie.hs │ │ ├── FormLogin.hs │ │ ├── JWT.hs │ │ ├── ThrowAll.hs │ │ └── Types.hs │ │ └── SetCookieOrphan.hs └── test │ ├── Servant │ └── Auth │ │ └── ServerSpec.hs │ └── Spec.hs ├── servant-auth-swagger ├── .ghci ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── servant-auth-swagger.cabal ├── src │ └── Servant │ │ └── Auth │ │ └── Swagger.hs └── test │ ├── Servant │ └── Auth │ │ └── SwaggerSpec.hs │ └── Spec.hs ├── servant-auth ├── .ghci ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── servant-auth.cabal ├── src │ └── Servant │ │ ├── Auth.hs │ │ └── Auth │ │ └── JWT.hs └── test │ └── Spec.hs ├── stack-lts16.yaml ├── stack-lts17.yaml └── stack.yaml /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | # Trigger the workflow on every pull request... 5 | pull_request: 6 | branches: 7 | - master 8 | # ...and when the main branch is updated. 9 | push: 10 | branches: 11 | - master 12 | # Build _at least_ once per month to actively check for regressions. 13 | schedule: 14 | - cron: '0 0 1 * *' 15 | 16 | jobs: 17 | cabal: 18 | name: ghc ${{ matrix.ghc }} 19 | runs-on: ${{ matrix.os }} 20 | # Not buildable ATM but it's good to keep an eye on it 21 | continue-on-error: ${{ matrix.ghc == '9.0.1' }} 22 | strategy: 23 | matrix: 24 | os: 25 | - ubuntu-latest 26 | # Check the last 3 (or so) major GHC releases; no need to waste compute. 27 | ghc: 28 | - 8.6.5 29 | - 8.8.4 30 | - 8.10.4 31 | - 9.0.1 32 | cabal: 33 | - latest 34 | 35 | steps: 36 | - uses: actions/checkout@v2 37 | 38 | - uses: haskell/actions/setup@v1 39 | id: setup-haskell-cabal 40 | name: Setup Cabal 41 | with: 42 | ghc-version: ${{ matrix.ghc }} 43 | cabal-version: ${{ matrix.cabal }} 44 | 45 | # Regenerate the freeze file on each run to ensure that `cabal-install` 46 | # always builds against the latest dependencies. 47 | - name: Freeze 48 | run: | 49 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 50 | cabal freeze 51 | 52 | - uses: actions/cache@v2 53 | name: Cache Cabal Artifacts 54 | with: 55 | path: | 56 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 57 | dist-newstyle 58 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 59 | restore-keys: ${{ runner.os }}-cabal-${{ matrix.ghc }}- 60 | 61 | - name: Build 62 | run: | 63 | cabal build all 64 | 65 | - name: Test 66 | run: | 67 | cabal test all 68 | 69 | - name: Generate Documentation 70 | run: | 71 | cabal haddock all 72 | 73 | stack: 74 | name: stack ${{ matrix.name }} 75 | runs-on: ${{ matrix.os }} 76 | strategy: 77 | matrix: 78 | os: 79 | - ubuntu-latest 80 | name: 81 | - nightly 82 | - lts16 83 | - lts17 84 | include: 85 | # Check that the build passes with the nightly snapshot. 86 | - name: 'nightly' 87 | stack_yaml: 'stack.yaml' 88 | # Check that the build passes with the latest LTS snapshot. 89 | - name: 'lts16' 90 | stack_yaml: 'stack-lts16.yaml' 91 | # Check that the build passes with the latest LTS snapshot. 92 | - name: 'lts17' 93 | stack_yaml: 'stack-lts17.yaml' 94 | 95 | steps: 96 | - uses: actions/checkout@v2 97 | 98 | - uses: actions/cache@v2 99 | name: Cache Stack Artifacts 100 | with: 101 | path: | 102 | ~/.stack 103 | .stack-work 104 | key: ${{ runner.os }}-stack-${{ matrix.stack_yaml }}-${{ hashFiles(matrix.stack_yaml) }} 105 | restore-keys: ${{ runner.os }}-stack-${{ matrix.stack_yaml }}- 106 | 107 | - uses: haskell/actions/setup@v1 108 | name: Stack Setup 109 | with: 110 | enable-stack: true 111 | stack-no-global: true 112 | stack-setup-ghc: true 113 | 114 | - name: Build 115 | run: | 116 | stack --stack-yaml=${{ matrix.stack_yaml }} build --test --bench --no-run-tests --no-run-benchmarks 117 | 118 | - name: Test 119 | run: | 120 | stack --stack-yaml=${{ matrix.stack_yaml }} test 121 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | dist-newstyle/ 3 | .ghc.environment.* 4 | .stack-work 5 | *.tix 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Servant-auth 2 | 3 | The Servant-auth repository has been moved into Servant main repository : [https://github.com/haskell-servant/servant/servant-auth/](https://github.com/haskell-servant/servant/servant-auth/) 4 | -------------------------------------------------------------------------------- /RELEASE.md: -------------------------------------------------------------------------------- 1 | - update changelog 2 | - bump version in cabal file 3 | - stack sdist servant-auth-server 4 | - git commit -m "v0.4.0.0" 5 | - git tag -s servant-auth-server-0.4.0.0 6 | - git push --tags 7 | - stack upload servant-auth-server 8 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | servant-auth 3 | servant-auth-client 4 | servant-auth-docs 5 | servant-auth-server 6 | servant-auth-swagger 7 | -------------------------------------------------------------------------------- /servant-auth-client/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -idoctest/ghci-wrapper/src 2 | -------------------------------------------------------------------------------- /servant-auth-client/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 6 | and this project adheres to [PVP Versioning](https://pvp.haskell.org/). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.4.1.0] - 2020-10-06 11 | 12 | - Support generic Bearer token auth 13 | 14 | ## [0.4.0.0] - 2019-03-08 15 | 16 | ## Changed 17 | 18 | - #145 Support servant-0.16 in tests @domenkozar 19 | - #145 Drop GHC 7.10 support @domenkozar 20 | 21 | ## [0.3.3.0] - 2018-06-18 22 | 23 | ### Added 24 | - Support for GHC 8.4 by @phadej 25 | - Support for servant-0.14 by @phadej 26 | - Changelog by @domenkozar 27 | -------------------------------------------------------------------------------- /servant-auth-client/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Julian K. Arni (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julian K. Arni nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /servant-auth-client/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /servant-auth-client/servant-auth-client.cabal: -------------------------------------------------------------------------------- 1 | name: servant-auth-client 2 | version: 0.4.1.0 3 | synopsis: servant-client/servant-auth compatibility 4 | description: This package provides instances that allow generating clients from 5 | 6 | APIs that use 7 | @Auth@ combinator. 8 | . 9 | For a quick overview of the usage, see the . 10 | category: Web, Servant, Authentication 11 | homepage: http://github.com/haskell-servant/servant-auth#readme 12 | bug-reports: https://github.com/haskell-servant/servant-auth/issues 13 | author: Julian K. Arni 14 | maintainer: jkarni@gmail.com 15 | copyright: (c) Julian K. Arni 16 | license: BSD3 17 | license-file: LICENSE 18 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 19 | build-type: Simple 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/haskell-servant/servant-auth 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 32 | ghc-options: -Wall 33 | build-depends: 34 | base >= 4.10 && < 4.16 35 | , bytestring >= 0.10.6.0 && < 0.11 36 | , containers >= 0.5.6.2 && < 0.7 37 | , servant-auth == 0.4.* 38 | , servant >= 0.13 && < 0.19 39 | , servant-client-core >= 0.13 && < 0.19 40 | 41 | exposed-modules: 42 | Servant.Auth.Client 43 | Servant.Auth.Client.Internal 44 | default-language: Haskell2010 45 | 46 | test-suite spec 47 | type: exitcode-stdio-1.0 48 | main-is: Spec.hs 49 | hs-source-dirs: 50 | test 51 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 52 | ghc-options: -Wall 53 | build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 54 | 55 | -- dependencies with bounds inherited from the library stanza 56 | build-depends: 57 | base 58 | , servant-client 59 | , servant-auth 60 | , servant 61 | , servant-auth-client 62 | 63 | -- test dependencies 64 | build-depends: 65 | hspec >= 2.5.5 && < 2.9 66 | , QuickCheck >= 2.11.3 && < 2.15 67 | , aeson >= 1.3.1.1 && < 1.6 68 | , bytestring >= 0.10.6.0 && < 0.11 69 | , http-client >= 0.5.13.1 && < 0.8 70 | , http-types >= 0.12.2 && < 0.13 71 | , servant-auth-server >= 0.4.2.0 && < 0.5 72 | , servant-server >= 0.13 && < 0.19 73 | , time >= 1.5.0.1 && < 1.13 74 | , transformers >= 0.4.2.0 && < 0.6 75 | , wai >= 3.2.1.2 && < 3.3 76 | , warp >= 3.2.25 && < 3.4 77 | , jose >= 0.7.0.0 && < 0.9 78 | other-modules: 79 | Servant.Auth.ClientSpec 80 | default-language: Haskell2010 81 | -------------------------------------------------------------------------------- /servant-auth-client/src/Servant/Auth/Client.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Client (Token(..), Bearer) where 2 | 3 | import Servant.Auth.Client.Internal (Bearer, Token(..)) 4 | -------------------------------------------------------------------------------- /servant-auth-client/src/Servant/Auth/Client/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | #if __GLASGOW_HASKELL__ == 800 6 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 7 | #endif 8 | module Servant.Auth.Client.Internal where 9 | 10 | import qualified Data.ByteString as BS 11 | import Data.Monoid 12 | import Data.Proxy (Proxy (..)) 13 | import Data.String (IsString) 14 | import GHC.Exts (Constraint) 15 | import GHC.Generics (Generic) 16 | import Servant.API ((:>)) 17 | import Servant.Auth 18 | 19 | import Servant.Client.Core 20 | import Data.Sequence ((<|)) 21 | 22 | -- | A simple bearer token. 23 | newtype Token = Token { getToken :: BS.ByteString } 24 | deriving (Eq, Show, Read, Generic, IsString) 25 | 26 | type family HasBearer xs :: Constraint where 27 | HasBearer (Bearer ': xs) = () 28 | HasBearer (JWT ': xs) = () 29 | HasBearer (x ': xs) = HasBearer xs 30 | HasBearer '[] = BearerAuthNotEnabled 31 | 32 | class BearerAuthNotEnabled 33 | 34 | -- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not 35 | -- trying to send a token to an API that doesn't accept them. 36 | instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where 37 | type Client m (Auth auths a :> api) = Token -> Client m api 38 | 39 | clientWithRoute m _ req (Token token) 40 | = clientWithRoute m (Proxy :: Proxy api) 41 | $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req } 42 | where 43 | headerVal = "Bearer " <> token 44 | 45 | #if MIN_VERSION_servant_client_core(0,14,0) 46 | hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl 47 | #endif 48 | 49 | 50 | -- * Authentication combinators 51 | 52 | -- | A Bearer token in the Authorization header: 53 | -- 54 | -- @Authorization: Bearer @ 55 | -- 56 | -- This can be any token recognized by the server, for example, 57 | -- a JSON Web Token (JWT). 58 | -- 59 | -- Note that, since the exact way the token is validated is not specified, 60 | -- this combinator can only be used in the client. The server would not know 61 | -- how to validate it, while the client does not care. 62 | -- If you want to implement Bearer authentication in your server, you have to 63 | -- choose a specific combinator, such as 'JWT'. 64 | data Bearer 65 | -------------------------------------------------------------------------------- /servant-auth-client/test/Servant/Auth/ClientSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | module Servant.Auth.ClientSpec (spec) where 4 | 5 | import Crypto.JOSE (JWK, 6 | KeyMaterialGenParam (OctGenParam), 7 | genJWK) 8 | import Data.Aeson (FromJSON (..), ToJSON (..)) 9 | import qualified Data.ByteString.Lazy as BSL 10 | import Data.Time (UTCTime, defaultTimeLocale, 11 | parseTimeOrError) 12 | import GHC.Generics (Generic) 13 | import Network.HTTP.Client (Manager, defaultManagerSettings, 14 | newManager) 15 | import Network.HTTP.Types (status401) 16 | import Network.Wai.Handler.Warp (testWithApplication) 17 | import Servant 18 | import Servant.Client (BaseUrl (..), Scheme (Http), 19 | ClientError (FailureResponse), 20 | #if MIN_VERSION_servant_client(0,16,0) 21 | ResponseF(..), 22 | #elif MIN_VERSION_servant_client(0,13,0) 23 | GenResponse(..), 24 | #elif MIN_VERSION_servant_client(0,12,0) 25 | Response(..), 26 | #endif 27 | client) 28 | import System.IO.Unsafe (unsafePerformIO) 29 | import Test.Hspec 30 | import Test.QuickCheck 31 | 32 | #if MIN_VERSION_servant_client(0,13,0) 33 | import Servant.Client (mkClientEnv, runClientM) 34 | #elif MIN_VERSION_servant_client(0,9,0) 35 | import Servant.Client (ClientEnv (..), runClientM) 36 | #else 37 | import Control.Monad.Trans.Except (runExceptT) 38 | #endif 39 | #if !MIN_VERSION_servant_server(0,16,0) 40 | #define ClientError ServantError 41 | #endif 42 | 43 | import Servant.Auth.Client 44 | import Servant.Auth.Server 45 | import Servant.Auth.Server.SetCookieOrphan () 46 | 47 | spec :: Spec 48 | spec = describe "The JWT combinator" $ do 49 | hasClientSpec 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- * HasClient {{{ 54 | 55 | hasClientSpec :: Spec 56 | hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do 57 | 58 | let mkTok :: User -> Maybe UTCTime -> IO Token 59 | mkTok user mexp = do 60 | Right tok <- makeJWT user jwtCfg mexp 61 | return $ Token $ BSL.toStrict tok 62 | 63 | it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do 64 | tok <- mkTok user Nothing 65 | v <- getIntClient tok mgr (BaseUrl Http "localhost" port "") 66 | v `shouldBe` Right (length $ name user) 67 | 68 | it "succeeds when the token is not expired" $ \port -> property $ \user -> do 69 | tok <- mkTok user (Just future) 70 | v <- getIntClient tok mgr (BaseUrl Http "localhost" port "") 71 | v `shouldBe` Right (length $ name user) 72 | 73 | it "fails when token is expired" $ \port -> property $ \user -> do 74 | tok <- mkTok user (Just past) 75 | #if MIN_VERSION_servant_client(0,16,0) 76 | Left (FailureResponse _ (Response stat _ _ _)) 77 | #elif MIN_VERSION_servant_client(0,12,0) 78 | Left (FailureResponse (Response stat _ _ _)) 79 | #elif MIN_VERSION_servant_client(0,11,0) 80 | Left (FailureResponse _ stat _ _) 81 | #else 82 | Left (FailureResponse stat _ _) 83 | #endif 84 | <- getIntClient tok mgr (BaseUrl Http "localhost" port "") 85 | stat `shouldBe` status401 86 | 87 | 88 | getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int) 89 | #if MIN_VERSION_servant(0,13,0) 90 | getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl) 91 | #elif MIN_VERSION_servant(0,9,0) 92 | getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl) 93 | #else 94 | getIntClient tok m burl = runExceptT $ client api tok m burl 95 | #endif 96 | -- }}} 97 | ------------------------------------------------------------------------------ 98 | -- * API and Server {{{ 99 | 100 | type API = Auth '[JWT] User :> Get '[JSON] Int 101 | 102 | api :: Proxy API 103 | api = Proxy 104 | 105 | theKey :: JWK 106 | theKey = unsafePerformIO . genJWK $ OctGenParam 256 107 | {-# NOINLINE theKey #-} 108 | 109 | mgr :: Manager 110 | mgr = unsafePerformIO $ newManager defaultManagerSettings 111 | {-# NOINLINE mgr #-} 112 | 113 | app :: Application 114 | app = serveWithContext api ctx server 115 | where 116 | ctx = cookieCfg :. jwtCfg :. EmptyContext 117 | 118 | jwtCfg :: JWTSettings 119 | jwtCfg = defaultJWTSettings theKey 120 | 121 | cookieCfg :: CookieSettings 122 | cookieCfg = defaultCookieSettings 123 | 124 | 125 | server :: Server API 126 | server = getInt 127 | where 128 | getInt :: AuthResult User -> Handler Int 129 | getInt (Authenticated u) = return . length $ name u 130 | getInt _ = throwAll err401 131 | 132 | 133 | -- }}} 134 | ------------------------------------------------------------------------------ 135 | -- * Utils {{{ 136 | 137 | past :: UTCTime 138 | past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01" 139 | 140 | future :: UTCTime 141 | future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01" 142 | 143 | 144 | -- }}} 145 | ------------------------------------------------------------------------------ 146 | -- * Types {{{ 147 | 148 | data User = User 149 | { name :: String 150 | , _id :: String 151 | } deriving (Eq, Show, Read, Generic) 152 | 153 | instance FromJWT User 154 | instance ToJWT User 155 | instance FromJSON User 156 | instance ToJSON User 157 | 158 | instance Arbitrary User where 159 | arbitrary = User <$> arbitrary <*> arbitrary 160 | 161 | -- }}} 162 | -------------------------------------------------------------------------------- /servant-auth-client/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /servant-auth-docs/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -idoctest/ghci-wrapper/src 2 | -------------------------------------------------------------------------------- /servant-auth-docs/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 6 | and this project adheres to [PVP Versioning](https://pvp.haskell.org/). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.2.10.0] - 2018-06-18 11 | 12 | ### Added 13 | - Support for GHC 8.4 by @phadej 14 | - Changelog by @domenkozar 15 | -------------------------------------------------------------------------------- /servant-auth-docs/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Julian K. Arni (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julian K. Arni nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /servant-auth-docs/Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | module Main (main) where 4 | 5 | #ifndef MIN_VERSION_cabal_doctest 6 | #define MIN_VERSION_cabal_doctest(x,y,z) 0 7 | #endif 8 | 9 | #if MIN_VERSION_cabal_doctest(1,0,0) 10 | 11 | import Distribution.Extra.Doctest ( defaultMainWithDoctests ) 12 | main :: IO () 13 | main = defaultMainWithDoctests "doctests" 14 | 15 | #else 16 | 17 | #ifdef MIN_VERSION_Cabal 18 | -- If the macro is defined, we have new cabal-install, 19 | -- but for some reason we don't have cabal-doctest in package-db 20 | -- 21 | -- Probably we are running cabal sdist, when otherwise using new-build 22 | -- workflow 23 | #warning You are configuring this package without cabal-doctest installed. \ 24 | The doctests test-suite will not work as a result. \ 25 | To fix this, install cabal-doctest before configuring. 26 | #endif 27 | 28 | import Distribution.Simple 29 | 30 | main :: IO () 31 | main = defaultMain 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /servant-auth-docs/servant-auth-docs.cabal: -------------------------------------------------------------------------------- 1 | name: servant-auth-docs 2 | version: 0.2.10.0 3 | synopsis: servant-docs/servant-auth compatibility 4 | description: This package provides instances that allow generating docs from 5 | 6 | APIs that use 7 | @Auth@ combinator. 8 | . 9 | For a quick overview of the usage, see the . 10 | category: Web, Servant, Authentication 11 | homepage: http://github.com/haskell-servant/servant-auth#readme 12 | bug-reports: https://github.com/haskell-servant/servant-auth/issues 13 | author: Julian K. Arni 14 | maintainer: jkarni@gmail.com 15 | copyright: (c) Julian K. Arni 16 | license: BSD3 17 | license-file: LICENSE 18 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 19 | build-type: Custom 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | CHANGELOG.md 23 | 24 | custom-setup 25 | setup-depends: 26 | base, Cabal, cabal-doctest >=1.0.6 && <1.1 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/haskell-servant/servant-auth 31 | 32 | library 33 | hs-source-dirs: 34 | src 35 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 36 | ghc-options: -Wall 37 | build-depends: 38 | base >= 4.10 && < 4.16 39 | , servant-docs >= 0.11.2 && < 0.12 40 | , servant >= 0.13 && < 0.19 41 | , servant-auth == 0.4.* 42 | , lens >= 4.16.1 && <5.1 43 | exposed-modules: 44 | Servant.Auth.Docs 45 | default-language: Haskell2010 46 | 47 | test-suite doctests 48 | type: exitcode-stdio-1.0 49 | main-is: doctests.hs 50 | build-depends: 51 | base, 52 | servant-auth-docs, 53 | doctest >= 0.16 && < 0.19, 54 | QuickCheck >= 2.11.3 && < 2.15, 55 | template-haskell 56 | ghc-options: -Wall -threaded 57 | hs-source-dirs: test 58 | default-language: Haskell2010 59 | 60 | test-suite spec 61 | type: exitcode-stdio-1.0 62 | main-is: Spec.hs 63 | hs-source-dirs: 64 | test 65 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 66 | ghc-options: -Wall 67 | build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 68 | 69 | -- dependencies with bounds inherited from the library stanza 70 | build-depends: 71 | base 72 | , text 73 | , servant-docs 74 | , servant 75 | , servant-auth 76 | , lens 77 | 78 | -- test dependencies 79 | build-depends: 80 | servant-auth-docs 81 | , hspec >= 2.5.5 && < 2.9 82 | , QuickCheck >= 2.11.3 && < 2.15 83 | 84 | default-language: Haskell2010 85 | -------------------------------------------------------------------------------- /servant-auth-docs/src/Servant/Auth/Docs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Servant.Auth.Docs 3 | ( 4 | -- | The purpose of this package is provide the instance for 'servant-auth' 5 | -- combinators needed for 'servant-docs' documentation generation. 6 | -- 7 | -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int 8 | -- >>> putStr $ markdown $ docs (Proxy :: Proxy API) 9 | -- ## GET / 10 | -- ... 11 | -- ... Authentication 12 | -- ... 13 | -- This part of the API is protected by the following authentication mechanisms: 14 | -- ... 15 | -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token)) 16 | -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie) 17 | -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication) 18 | -- ... 19 | -- Clients must supply the following data 20 | -- ... 21 | -- One of the following: 22 | -- ... 23 | -- * A JWT Token signed with this server's key 24 | -- * Cookies automatically set by browsers, plus a header 25 | -- * Cookies automatically set by browsers, plus a header 26 | -- ... 27 | 28 | -- * Re-export 29 | JWT 30 | , BasicAuth 31 | , Cookie 32 | , Auth 33 | ) where 34 | 35 | import Control.Lens ((%~), (&), (|>)) 36 | import Data.List (intercalate) 37 | import Data.Monoid 38 | import Data.Proxy (Proxy (Proxy)) 39 | import Servant.API hiding (BasicAuth) 40 | import Servant.Auth 41 | import Servant.Docs hiding (pretty) 42 | import Servant.Docs.Internal (DocAuthentication (..), authInfo) 43 | 44 | instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where 45 | docsFor _ (endpoint, action) = 46 | docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info)) 47 | where 48 | (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths) 49 | info = DocAuthentication intro reqData 50 | 51 | 52 | pretty :: [(String, String)] -> (String, String) 53 | pretty [] = error "shouldn't happen" 54 | pretty [(i, d)] = 55 | ( "This part of the API is protected by " <> i 56 | , d 57 | ) 58 | pretty rs = 59 | ( "This part of the API is protected by the following authentication mechanisms:\n\n" 60 | ++ " * " <> intercalate "\n * " (fst <$> rs) 61 | , "\nOne of the following:\n\n" 62 | ++ " * " <> intercalate "\n * " (snd <$> rs) 63 | ) 64 | 65 | 66 | class AllDocs (x :: [*]) where 67 | allDocs :: proxy x 68 | -- intro, req 69 | -> [(String, String)] 70 | 71 | instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where 72 | allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as) 73 | 74 | instance AllDocs '[] where 75 | allDocs _ = [] 76 | 77 | class OneDoc a where 78 | oneDoc :: proxy a -> (String, String) 79 | 80 | instance OneDoc JWT where 81 | oneDoc _ = 82 | ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))" 83 | , "A JWT Token signed with this server's key") 84 | 85 | instance OneDoc Cookie where 86 | oneDoc _ = 87 | ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)" 88 | , "Cookies automatically set by browsers, plus a header") 89 | 90 | instance OneDoc BasicAuth where 91 | oneDoc _ = 92 | ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)" 93 | , "Cookies automatically set by browsers, plus a header") 94 | 95 | -- $setup 96 | -- >>> instance ToSample Int where toSamples _ = singleSample 1729 97 | -------------------------------------------------------------------------------- /servant-auth-docs/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /servant-auth-docs/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Data.Foldable (traverse_) 5 | import Test.DocTest 6 | 7 | main :: IO () 8 | main = do 9 | traverse_ putStrLn args 10 | doctest args 11 | where 12 | args = flags ++ pkgs ++ module_sources 13 | -------------------------------------------------------------------------------- /servant-auth-server/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -idoctest/ghci-wrapper/src 2 | -------------------------------------------------------------------------------- /servant-auth-server/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 6 | and this project adheres to [PVP Versioning](https://pvp.haskell.org/). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.4.6.0] - 2020-10-06 11 | 12 | ## Changed 13 | 14 | - expose verifyJWT and use it in two places [@domenkozar] 15 | - support GHC 8.10 [@domenkozar] 16 | - move ToJWT/FromJWT to servant-auth [@erewok] 17 | - #165 fix AnySite with Cookie 3.5.0 [@odr] 18 | 19 | ## [0.4.5.1] - 2020-02-06 20 | 21 | ## Changed 22 | 23 | - #158 servant 0.17 support [@phadej] 24 | 25 | ## [0.4.5.0] - 2019-12-28 26 | 27 | ## Changed 28 | - #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar] 29 | - #148 removed unused constaint in HasServer instance for Auth 30 | - #154 GHC 8.8 support [@phadej] 31 | 32 | ### Added 33 | - #141 Support Stream combinator [@domenkozar] 34 | - #143 Allow servant-0.16 [@phadej] 35 | 36 | ## [0.4.4.0] - 2019-03-02 37 | 38 | ### Added 39 | - #141 Support Stream combinator [@domenkozar] 40 | - #143 Allow servant-0.16 [@phadej] 41 | 42 | ## [0.4.3.0] - 2019-01-17 43 | 44 | ## Changed 45 | - #117 Avoid running auth checks unnecessarily [@sopvop] 46 | - #110 Get rid of crypto-api dependency [@domenkozar] 47 | - #130 clearSession: improve cross-browser compatibility [@domenkozar] 48 | - #136 weed out bytestring-conversion [@stephenirl] 49 | 50 | ## [0.4.2.0] - 2018-11-05 51 | 52 | ### Added 53 | - `Headers hs a` instance for AddSetCookieApi [@domenkozar] 54 | - GHC 8.6.x support [@domenkozar] 55 | 56 | ## [0.4.1.0] - 2018-10-05 57 | 58 | ### Added 59 | - #125 Allow setting domain name for a cookie [@domenkozar] 60 | 61 | ## Changed 62 | - bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej] 63 | - #114 Export `HasSecurity` typeclass [@rockbmb] 64 | 65 | ## [0.4.0.1] - 2018-09-23 66 | 67 | ### Security 68 | - #123 Session cookie did not apply SameSite attribute [@domenkozar] 69 | 70 | ### Added 71 | - #112 HasLink instance for Auth combinator [@adetokunbo] 72 | - #111 Documentation for using hoistServer [@mschristiansen] 73 | - #107 Add utility functions for reading and writing a key to a file [@mschristiansen] 74 | 75 | ## [0.4.0.0] - 2018-06-17 76 | 77 | ### Added 78 | - Support GHC 8.4 by @phadej and @domenkozar 79 | - Support for servant-0.14 by @phadej 80 | - #96 Support for jose-0.7 by @xaviershay 81 | - #92 add `clearSession` for logout by @plredmond and @3noch 82 | - #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar 83 | - #89 Validate JWT against a JWKSet instead of JWK by @sopvop 84 | 85 | ### Changed 86 | - #92 Rename CSRF to XSRF by @plredmond and @3noch 87 | - #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional 88 | by @plredmond and @3noch 89 | - #69 export SameSite by @domenkozar 90 | - #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar 91 | 92 | ### Deprecated 93 | - #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated 94 | by @plredmond and @3noc 95 | - #92 Made several changes to the structure of 'CookieSettings' which will require 96 | attention by users who have modified the XSRF settings by @plredmond and @3noch 97 | 98 | ### Security 99 | - #94 Force cookie expiration on serverside by @karshan 100 | 101 | ## [0.3.2.0] - 2018-02-21 102 | 103 | ### Added 104 | - #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor 105 | - Support for servant-0.14 by @phadej 106 | 107 | ### Changed 108 | - Disable the readme executable for ghcjs builds by @hamishmack 109 | - #84 Make AddSetCookieApi type family open by @qnikst 110 | - #79 Make CSRF checks optional for GET requests by @harendra-kumar 111 | 112 | ## [0.3.1.0] - 2017-11-08 113 | 114 | ### Added 115 | - Support for servant-0.12 by @phadej 116 | 117 | ## [0.3.0.0] - 2017-11-07 118 | 119 | ### Changed 120 | - #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver 121 | 122 | ## [0.2.8.0] - 2017-05-26 123 | 124 | ### Added 125 | - #45 Support for servant-0.11 by @phadej 126 | 127 | ## [0.2.7.0] - 2017-02-11 128 | 129 | ### Changed 130 | - #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts 131 | -------------------------------------------------------------------------------- /servant-auth-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Julian K. Arni (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julian K. Arni nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /servant-auth-server/README.lhs: -------------------------------------------------------------------------------- 1 | # servant-auth 2 | 3 | [![build status](https://img.shields.io/github/workflow/status/haskell-servant/servant-auth/CI/master?style=flat-square&logo=github&label=build%20status)](https://github.com/haskell-servant/servant-auth/actions?query=workflow%3ACI) 4 | 5 | These packages provides safe and easy-to-use authentication options for 6 | `servant`. The same API can be protected via: 7 | - basicauth 8 | - cookies 9 | - JWT tokens 10 | 11 | 12 | | Package | Hackage | 13 | | -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | 14 | | servant-auth | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) | 15 | | servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) | 16 | | servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) | 17 | | servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) | 18 | | servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) | 19 | 20 | ## How it works 21 | 22 | First some imports: 23 | 24 | ~~~ haskell 25 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 26 | {-# OPTIONS_GHC -fno-warn-deprecations #-} 27 | import Control.Concurrent (forkIO) 28 | import Control.Monad (forever) 29 | import Control.Monad.Trans (liftIO) 30 | import Data.Aeson (FromJSON, ToJSON) 31 | import GHC.Generics (Generic) 32 | import Network.Wai.Handler.Warp (run) 33 | import System.Environment (getArgs) 34 | import Servant 35 | import Servant.Auth.Server 36 | import Servant.Auth.Server.SetCookieOrphan () 37 | ~~~ 38 | 39 | `servant-auth` library introduces a combinator `Auth`: 40 | 41 | ~~~ haskell 42 | data Auth (auths :: [*]) val 43 | ~~~ 44 | 45 | What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by 46 | *either* `Auth1` *or* `Auth2`, and the result of authentication will be of type 47 | `AuthResult Something`, where : 48 | 49 | ~~~ haskell 50 | data AuthResult val 51 | = BadPassword 52 | | NoSuchUser 53 | | Authenticated val 54 | | Indefinite 55 | ~~~ 56 | 57 | Your handlers will get a value of type `AuthResult Something`, and can decide 58 | what to do with it. 59 | 60 | ~~~ haskell 61 | 62 | data User = User { name :: String, email :: String } 63 | deriving (Eq, Show, Read, Generic) 64 | 65 | instance ToJSON User 66 | instance ToJWT User 67 | instance FromJSON User 68 | instance FromJWT User 69 | 70 | data Login = Login { username :: String, password :: String } 71 | deriving (Eq, Show, Read, Generic) 72 | 73 | instance ToJSON Login 74 | instance FromJSON Login 75 | 76 | type Protected 77 | = "name" :> Get '[JSON] String 78 | :<|> "email" :> Get '[JSON] String 79 | 80 | 81 | -- | 'Protected' will be protected by 'auths', which we still have to specify. 82 | protected :: Servant.Auth.Server.AuthResult User -> Server Protected 83 | -- If we get an "Authenticated v", we can trust the information in v, since 84 | -- it was signed by a key we trust. 85 | protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user) 86 | -- Otherwise, we return a 401. 87 | protected _ = throwAll err401 88 | 89 | type Unprotected = 90 | "login" 91 | :> ReqBody '[JSON] Login 92 | :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie 93 | , Header "Set-Cookie" SetCookie] 94 | NoContent) 95 | :<|> Raw 96 | 97 | unprotected :: CookieSettings -> JWTSettings -> Server Unprotected 98 | unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static" 99 | 100 | type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected 101 | 102 | server :: CookieSettings -> JWTSettings -> Server (API auths) 103 | server cs jwts = protected :<|> unprotected cs jwts 104 | 105 | ~~~ 106 | 107 | The code is common to all authentications. In order to pick one or more specific 108 | authentication methods, all we need to do is provide the expect configuration 109 | parameters. 110 | 111 | ## API tokens 112 | 113 | The following example illustrates how to protect an API with tokens. 114 | 115 | 116 | ~~~ haskell 117 | -- In main, we fork the server, and allow new tokens to be created in the 118 | -- command line for the specified user name and email. 119 | mainWithJWT :: IO () 120 | mainWithJWT = do 121 | -- We generate the key for signing tokens. This would generally be persisted, 122 | -- and kept safely 123 | myKey <- generateKey 124 | -- Adding some configurations. All authentications require CookieSettings to 125 | -- be in the context. 126 | let jwtCfg = defaultJWTSettings myKey 127 | cfg = defaultCookieSettings :. jwtCfg :. EmptyContext 128 | --- Here we actually make concrete 129 | api = Proxy :: Proxy (API '[JWT]) 130 | _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) 131 | 132 | putStrLn "Started server on localhost:7249" 133 | putStrLn "Enter name and email separated by a space for a new token" 134 | 135 | forever $ do 136 | xs <- words <$> getLine 137 | case xs of 138 | [name', email'] -> do 139 | etoken <- makeJWT (User name' email') jwtCfg Nothing 140 | case etoken of 141 | Left e -> putStrLn $ "Error generating token:t" ++ show e 142 | Right v -> putStrLn $ "New token:\t" ++ show v 143 | _ -> putStrLn "Expecting a name and email separated by spaces" 144 | 145 | ~~~ 146 | 147 | And indeed: 148 | 149 | ~~~ bash 150 | 151 | ./readme JWT 152 | 153 | Started server on localhost:7249 154 | Enter name and email separated by a space for a new token 155 | alice alice@gmail.com 156 | New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" 157 | 158 | curl localhost:7249/name -v 159 | 160 | * Hostname was NOT found in DNS cache 161 | * Trying 127.0.0.1... 162 | * Connected to localhost (127.0.0.1) port 7249 (#0) 163 | > GET /name HTTP/1.1 164 | > User-Agent: curl/7.35.0 165 | > Host: localhost:7249 166 | > Accept: */* 167 | > 168 | < HTTP/1.1 401 Unauthorized 169 | < Transfer-Encoding: chunked 170 | < Date: Wed, 07 Sep 2016 20:17:17 GMT 171 | * Server Warp/3.2.7 is not blacklisted 172 | < Server: Warp/3.2.7 173 | < 174 | * Connection #0 to host localhost left intact 175 | 176 | curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \ 177 | localhost:7249/name -v 178 | 179 | * Hostname was NOT found in DNS cache 180 | * Trying 127.0.0.1... 181 | * Connected to localhost (127.0.0.1) port 7249 (#0) 182 | > GET /name HTTP/1.1 183 | > User-Agent: curl/7.35.0 184 | > Host: localhost:7249 185 | > Accept: */* 186 | > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE 187 | > 188 | < HTTP/1.1 200 OK 189 | < Transfer-Encoding: chunked 190 | < Date: Wed, 07 Sep 2016 20:16:11 GMT 191 | * Server Warp/3.2.7 is not blacklisted 192 | < Server: Warp/3.2.7 193 | < Content-Type: application/json 194 | < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure 195 | < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure 196 | < 197 | * Connection #0 to host localhost left intact 198 | "alice"% 199 | 200 | 201 | ~~~ 202 | 203 | ## Cookies 204 | 205 | What if, in addition to API tokens, we want to expose our API to browsers? All 206 | we need to do is say so! 207 | 208 | ~~~ haskell 209 | mainWithCookies :: IO () 210 | mainWithCookies = do 211 | -- We *also* need a key to sign the cookies 212 | myKey <- generateKey 213 | -- Adding some configurations. 'Cookie' requires, in addition to 214 | -- CookieSettings, JWTSettings (for signing), so everything is just as before 215 | let jwtCfg = defaultJWTSettings myKey 216 | cfg = defaultCookieSettings :. jwtCfg :. EmptyContext 217 | --- Here is the actual change 218 | api = Proxy :: Proxy (API '[Cookie]) 219 | run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) 220 | 221 | -- Here is the login handler 222 | checkCreds :: CookieSettings 223 | -> JWTSettings 224 | -> Login 225 | -> Handler (Headers '[ Header "Set-Cookie" SetCookie 226 | , Header "Set-Cookie" SetCookie] 227 | NoContent) 228 | checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do 229 | -- Usually you would ask a database for the user info. This is just a 230 | -- regular servant handler, so you can follow your normal database access 231 | -- patterns (including using 'enter'). 232 | let usr = User "Ali Baba" "ali@email.com" 233 | mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr 234 | case mApplyCookies of 235 | Nothing -> throwError err401 236 | Just applyCookies -> return $ applyCookies NoContent 237 | checkCreds _ _ _ = throwError err401 238 | ~~~ 239 | 240 | ### XSRF and the frontend 241 | 242 | XSRF protection works by requiring that there be a header of the same value as 243 | a distinguished cookie that is set by the server on each request. What the 244 | cookie and header name are can be configured (see `xsrfCookieName` and 245 | `xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and 246 | "X-XSRF-TOKEN". This means that, if your client is a browser and you're using 247 | cookies, Javascript on the client must set the header of each request by 248 | reading the cookie. For jQuery, and with the default values, that might be: 249 | 250 | ~~~ javascript 251 | 252 | var token = (function() { 253 | r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)')) 254 | if (r) return r[1]; 255 | })(); 256 | 257 | 258 | $.ajaxPrefilter(function(opts, origOpts, xhr) { 259 | xhr.setRequestHeader('X-XSRF-TOKEN', token); 260 | } 261 | 262 | ~~~ 263 | 264 | I *believe* nothing at all needs to be done if you're using Angular's `$http` 265 | directive, but I haven't tested this. 266 | 267 | XSRF protection can be disabled just for `GET` requests by setting 268 | `xsrfExcludeGet = False`. You might want this if you're relying on the browser 269 | to navigate between pages that require cookie authentication. 270 | 271 | XSRF protection can be completely disabled by setting `cookieXsrfSetting = 272 | Nothing` in `CookieSettings`. This is not recommended! If your cookie 273 | authenticated web application runs any javascript, it's recommended to send the 274 | XSRF header. However, if your web application runs no javascript, disabling 275 | XSRF entirely may be required. 276 | 277 | # Note on this README 278 | 279 | This README is a literate haskell file. Here is 'main', allowing you to pick 280 | between the examples above. 281 | 282 | ~~~ haskell 283 | 284 | main :: IO () 285 | main = do 286 | args <- getArgs 287 | let usage = "Usage: readme (JWT|Cookie)" 288 | case args of 289 | ["JWT"] -> mainWithJWT 290 | ["Cookie"] -> mainWithCookies 291 | e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage 292 | 293 | ~~~ 294 | -------------------------------------------------------------------------------- /servant-auth-server/README.md: -------------------------------------------------------------------------------- 1 | README.lhs -------------------------------------------------------------------------------- /servant-auth-server/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /servant-auth-server/servant-auth-server.cabal: -------------------------------------------------------------------------------- 1 | name: servant-auth-server 2 | version: 0.4.6.0 3 | synopsis: servant-server/servant-auth compatibility 4 | description: This package provides the required instances for using the @Auth@ combinator 5 | in your 'servant' server. 6 | . 7 | Both cookie- and token- (REST API) based authentication is provided. 8 | . 9 | For a quick overview of the usage, see the . 10 | category: Web, Servant, Authentication 11 | homepage: http://github.com/haskell-servant/servant-auth#readme 12 | bug-reports: https://github.com/haskell-servant/servant-auth/issues 13 | author: Julian K. Arni 14 | maintainer: jkarni@gmail.com 15 | copyright: (c) Julian K. Arni 16 | license: BSD3 17 | license-file: LICENSE 18 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 19 | build-type: Simple 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/haskell-servant/servant-auth 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 32 | ghc-options: -Wall 33 | build-depends: 34 | base >= 4.10 && < 4.16 35 | , aeson >= 1.3.1.1 && < 1.6 36 | , base64-bytestring >= 1.0.0.1 && < 1.2 37 | , blaze-builder >= 0.4.1.0 && < 0.5 38 | , bytestring >= 0.10.6.0 && < 0.11 39 | , case-insensitive >= 1.2.0.11 && < 1.3 40 | , cookie >= 0.4.4 && < 0.5 41 | , data-default-class >= 0.1.2.0 && < 0.2 42 | , entropy >= 0.4.1.3 && < 0.5 43 | , http-types >= 0.12.2 && < 0.13 44 | , jose >= 0.7.0.0 && < 0.9 45 | , lens >= 4.16.1 && < 5.1 46 | , memory >= 0.14.16 && < 0.17 47 | , monad-time >= 0.3.1.0 && < 0.4 48 | , mtl >= 2.2.2 && < 2.3 49 | , servant >= 0.13 && < 0.19 50 | , servant-auth == 0.4.* 51 | , servant-server >= 0.13 && < 0.19 52 | , tagged >= 0.8.4 && < 0.9 53 | , text >= 1.2.3.0 && < 1.3 54 | , time >= 1.5.0.1 && < 1.10 55 | , unordered-containers >= 0.2.9.0 && < 0.3 56 | , wai >= 3.2.1.2 && < 3.3 57 | if !impl(ghc >= 8.0) 58 | build-depends: 59 | semigroups >= 0.18.5 && <0.20 60 | exposed-modules: 61 | Servant.Auth.Server 62 | Servant.Auth.Server.Internal 63 | Servant.Auth.Server.Internal.AddSetCookie 64 | Servant.Auth.Server.Internal.BasicAuth 65 | Servant.Auth.Server.Internal.Class 66 | Servant.Auth.Server.Internal.ConfigTypes 67 | Servant.Auth.Server.Internal.Cookie 68 | Servant.Auth.Server.Internal.FormLogin 69 | Servant.Auth.Server.Internal.JWT 70 | Servant.Auth.Server.Internal.ThrowAll 71 | Servant.Auth.Server.Internal.Types 72 | Servant.Auth.Server.SetCookieOrphan 73 | default-language: Haskell2010 74 | 75 | test-suite readme 76 | type: exitcode-stdio-1.0 77 | main-is: README.lhs 78 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 79 | ghc-options: -Wall -pgmL markdown-unlit 80 | build-tool-depends: markdown-unlit:markdown-unlit 81 | build-depends: 82 | base 83 | , servant-auth 84 | , servant-auth-server 85 | , servant-server 86 | , aeson 87 | , mtl 88 | , warp 89 | default-language: Haskell2010 90 | if impl(ghcjs) 91 | buildable: False 92 | 93 | test-suite spec 94 | type: exitcode-stdio-1.0 95 | main-is: Spec.hs 96 | hs-source-dirs: 97 | test 98 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 99 | ghc-options: -Wall 100 | build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8 101 | 102 | -- dependencies with bounds inherited from the library stanza 103 | build-depends: 104 | base 105 | , aeson 106 | , bytestring 107 | , case-insensitive 108 | , jose 109 | , lens 110 | , mtl 111 | , time 112 | , http-types 113 | , wai 114 | , servant 115 | , servant-server 116 | , transformers 117 | 118 | -- test dependencies 119 | build-depends: 120 | servant-auth-server 121 | , hspec >= 2.5.5 && < 2.8 122 | , QuickCheck >= 2.11.3 && < 2.15 123 | , http-client >= 0.5.13.1 && < 0.8 124 | , lens-aeson >= 1.0.2 && < 1.2 125 | , warp >= 3.2.25 && < 3.4 126 | , wreq >= 0.5.2.1 && < 0.6 127 | other-modules: 128 | Servant.Auth.ServerSpec 129 | default-language: Haskell2010 130 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Server 2 | ( 3 | -- | This package provides implementations for some common authentication 4 | -- methods. Authentication yields a trustworthy (because generated by the 5 | -- server) value of an some arbitrary type: 6 | -- 7 | -- > type MyApi = Protected 8 | -- > 9 | -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails 10 | -- > 11 | -- > server :: Server Protected 12 | -- > server (Authenticated usr) = ... -- here we know the client really is 13 | -- > -- who she claims to be 14 | -- > server _ = throwAll err401 15 | -- 16 | -- Additional configuration happens via 'Context'. 17 | -- 18 | -- == Example for Custom Handler 19 | -- To use a custom 'Servant.Server.Handler' it is necessary to use 20 | -- 'Servant.Server.hoistServerWithContext' instead of 21 | -- 'Servant.Server.hoistServer' and specify the 'Context'. 22 | -- 23 | -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the 24 | -- 'Context' to create a specialized function equivalent to 25 | -- 'Servant.Server.hoistServer' for an API that includes cookie 26 | -- authentication. 27 | -- 28 | -- > hoistServerWithAuth 29 | -- > :: HasServer api '[CookieSettings, JWTSettings] 30 | -- > => Proxy api 31 | -- > -> (forall x. m x -> n x) 32 | -- > -> ServerT api m 33 | -- > -> ServerT api n 34 | -- > hoistServerWithAuth api = 35 | -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) 36 | 37 | ---------------------------------------------------------------------------- 38 | -- * Auth 39 | -- | Basic types 40 | Auth 41 | , AuthResult(..) 42 | , AuthCheck(..) 43 | 44 | ---------------------------------------------------------------------------- 45 | -- * JWT 46 | -- | JSON Web Tokens (JWT) are a compact and secure way of transferring 47 | -- information between parties. In this library, they are signed by the 48 | -- server (or by some other party posessing the relevant key), and used to 49 | -- indicate the bearer's identity or authorization. 50 | -- 51 | -- Arbitrary information can be encoded - just declare instances for the 52 | -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that 53 | -- usually you'll be trasmitting this information on each request (and 54 | -- response!). 55 | -- 56 | -- Note that, while the tokens are signed, they are not encrypted. Do not put 57 | -- any information you do not wish the client to know in them! 58 | 59 | -- ** Combinator 60 | -- | Re-exported from 'servant-auth' 61 | , JWT 62 | 63 | -- ** Classes 64 | , FromJWT(..) 65 | , ToJWT(..) 66 | 67 | -- ** Related types 68 | , IsMatch(..) 69 | 70 | -- ** Settings 71 | , JWTSettings(..) 72 | , defaultJWTSettings 73 | 74 | -- ** Create check 75 | , jwtAuthCheck 76 | 77 | 78 | ---------------------------------------------------------------------------- 79 | -- * Cookie 80 | -- | Cookies are also a method of identifying and authenticating a user. They 81 | -- are particular common when the client is a browser 82 | 83 | -- ** Combinator 84 | -- | Re-exported from 'servant-auth' 85 | , Cookie 86 | 87 | -- ** Settings 88 | , CookieSettings(..) 89 | , XsrfCookieSettings(..) 90 | , defaultCookieSettings 91 | , defaultXsrfCookieSettings 92 | , makeSessionCookie 93 | , makeSessionCookieBS 94 | , makeXsrfCookie 95 | , makeCsrfCookie 96 | , makeCookie 97 | , makeCookieBS 98 | , acceptLogin 99 | , clearSession 100 | 101 | 102 | -- ** Related types 103 | , IsSecure(..) 104 | , SameSite(..) 105 | , AreAuths 106 | 107 | ---------------------------------------------------------------------------- 108 | -- * BasicAuth 109 | -- ** Combinator 110 | -- | Re-exported from 'servant-auth' 111 | , BasicAuth 112 | 113 | -- ** Classes 114 | , FromBasicAuthData(..) 115 | 116 | -- ** Settings 117 | , BasicAuthCfg 118 | 119 | -- ** Related types 120 | , BasicAuthData(..) 121 | , IsPasswordCorrect(..) 122 | 123 | -- ** Authentication request 124 | , wwwAuthenticatedErr 125 | 126 | ---------------------------------------------------------------------------- 127 | -- * Utilies 128 | , ThrowAll(throwAll) 129 | , generateKey 130 | , generateSecret 131 | , fromSecret 132 | , writeKey 133 | , readKey 134 | , makeJWT 135 | , verifyJWT 136 | 137 | -- ** Re-exports 138 | , Default(def) 139 | , SetCookie 140 | ) where 141 | 142 | import Prelude hiding (readFile, writeFile) 143 | import Data.ByteString (ByteString, writeFile, readFile) 144 | import Data.Default.Class (Default (def)) 145 | import Servant.Auth 146 | import Servant.Auth.JWT 147 | import Servant.Auth.Server.Internal () 148 | import Servant.Auth.Server.Internal.BasicAuth 149 | import Servant.Auth.Server.Internal.Class 150 | import Servant.Auth.Server.Internal.ConfigTypes 151 | import Servant.Auth.Server.Internal.Cookie 152 | import Servant.Auth.Server.Internal.JWT 153 | import Servant.Auth.Server.Internal.ThrowAll 154 | import Servant.Auth.Server.Internal.Types 155 | 156 | import Crypto.JOSE as Jose 157 | import Servant (BasicAuthData (..)) 158 | import Web.Cookie (SetCookie) 159 | 160 | -- | Generate a key suitable for use with 'defaultConfig'. 161 | generateKey :: IO Jose.JWK 162 | generateKey = Jose.genJWK $ Jose.OctGenParam 256 163 | 164 | -- | Generate a bytestring suitable for use with 'fromSecret'. 165 | generateSecret :: MonadRandom m => m ByteString 166 | generateSecret = Jose.getRandomBytes 256 167 | 168 | -- | Restores a key from a bytestring. 169 | fromSecret :: ByteString -> Jose.JWK 170 | fromSecret = Jose.fromOctets 171 | 172 | -- | Writes a secret to a file. Can for instance be used from the REPL 173 | -- to persist a key to a file, which can then be included with the 174 | -- application. Restore the key using 'readKey'. 175 | writeKey :: FilePath -> IO () 176 | writeKey fp = writeFile fp =<< generateSecret 177 | 178 | -- | Reads a key from a file. 179 | readKey :: FilePath -> IO Jose.JWK 180 | readKey fp = fromSecret <$> readFile fp 181 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Servant.Auth.Server.Internal where 6 | 7 | import Control.Monad.Trans (liftIO) 8 | import Servant ((:>), Handler, HasServer (..), 9 | Proxy (..), 10 | HasContextEntry(getContextEntry)) 11 | import Servant.Auth 12 | import Servant.Auth.JWT (ToJWT) 13 | 14 | import Servant.Auth.Server.Internal.AddSetCookie 15 | import Servant.Auth.Server.Internal.Class 16 | import Servant.Auth.Server.Internal.Cookie 17 | import Servant.Auth.Server.Internal.ConfigTypes 18 | import Servant.Auth.Server.Internal.JWT 19 | import Servant.Auth.Server.Internal.Types 20 | 21 | import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) 22 | 23 | instance ( n ~ 'S ('S 'Z) 24 | , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v 25 | , HasServer api ctxs -- this constraint is needed to implement hoistServer 26 | , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) 27 | , ToJWT v 28 | , HasContextEntry ctxs CookieSettings 29 | , HasContextEntry ctxs JWTSettings 30 | ) => HasServer (Auth auths v :> api) ctxs where 31 | type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m 32 | 33 | #if MIN_VERSION_servant_server(0,12,0) 34 | hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s 35 | #endif 36 | 37 | route _ context subserver = 38 | route (Proxy :: Proxy (AddSetCookiesApi n api)) 39 | context 40 | (fmap go subserver `addAuthCheck` authCheck) 41 | 42 | where 43 | authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) 44 | authCheck = withRequest $ \req -> liftIO $ do 45 | authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req 46 | cookies <- makeCookies authResult 47 | return (authResult, cookies) 48 | 49 | jwtSettings :: JWTSettings 50 | jwtSettings = getContextEntry context 51 | 52 | cookieSettings :: CookieSettings 53 | cookieSettings = getContextEntry context 54 | 55 | makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z))) 56 | makeCookies authResult = do 57 | xsrf <- makeXsrfCookie cookieSettings 58 | fmap (Just xsrf `SetCookieCons`) $ 59 | case authResult of 60 | (Authenticated v) -> do 61 | ejwt <- makeSessionCookie cookieSettings jwtSettings v 62 | case ejwt of 63 | Nothing -> return $ Nothing `SetCookieCons` SetCookieNil 64 | Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil 65 | _ -> return $ Nothing `SetCookieCons` SetCookieNil 66 | 67 | go :: (AuthResult v -> ServerT api Handler) 68 | -> (AuthResult v, SetCookieList n) 69 | -> ServerT (AddSetCookiesApi n api) Handler 70 | go fn (authResult, cookies) = addSetCookies cookies $ fn authResult 71 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE CPP #-} 5 | 6 | module Servant.Auth.Server.Internal.AddSetCookie where 7 | 8 | import Blaze.ByteString.Builder (toByteString) 9 | import qualified Data.ByteString as BS 10 | import Data.Tagged (Tagged (..)) 11 | import qualified Network.HTTP.Types as HTTP 12 | import Network.Wai (mapResponseHeaders) 13 | import Servant 14 | import Web.Cookie 15 | 16 | -- What are we doing here? Well, the idea is to add headers to the response, 17 | -- but the headers come from the authentication check. In order to do that, we 18 | -- tweak a little the general theme of recursing down the API tree; this time, 19 | -- we recurse down a variation of it that adds headers to all the endpoints. 20 | -- This involves the usual type-level checks. 21 | -- 22 | -- TODO: If the endpoints already have headers, this will not work as is. 23 | 24 | data Nat = Z | S Nat 25 | 26 | type family AddSetCookiesApi (n :: Nat) a where 27 | AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a 28 | AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a) 29 | 30 | type family AddSetCookieApiVerb a where 31 | AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a 32 | AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a 33 | 34 | type family AddSetCookieApi a :: * 35 | type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b 36 | type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b 37 | type instance AddSetCookieApi (Verb method stat ctyps a) 38 | = Verb method stat ctyps (AddSetCookieApiVerb a) 39 | type instance AddSetCookieApi Raw = Raw 40 | #if MIN_VERSION_servant_server(0,15,0) 41 | type instance AddSetCookieApi (Stream method stat framing ctyps a) 42 | = Stream method stat framing ctyps (AddSetCookieApiVerb a) 43 | #endif 44 | type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a) 45 | 46 | data SetCookieList (n :: Nat) :: * where 47 | SetCookieNil :: SetCookieList 'Z 48 | SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n) 49 | 50 | class AddSetCookies (n :: Nat) orig new where 51 | addSetCookies :: SetCookieList n -> orig -> new 52 | 53 | instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb 54 | => AddSetCookies ('S n) (a -> oldb) (a -> newb) where 55 | addSetCookies cookies oldfn = addSetCookies cookies . oldfn 56 | 57 | instance AddSetCookies 'Z orig orig where 58 | addSetCookies _ = id 59 | 60 | instance {-# OVERLAPPABLE #-} 61 | ( Functor m 62 | , AddSetCookies n (m old) (m cookied) 63 | , AddHeader "Set-Cookie" SetCookie cookied new 64 | ) => AddSetCookies ('S n) (m old) (m new) where 65 | addSetCookies (mCookie `SetCookieCons` rest) oldVal = 66 | case mCookie of 67 | Nothing -> noHeader <$> addSetCookies rest oldVal 68 | Just cookie -> addHeader cookie <$> addSetCookies rest oldVal 69 | 70 | instance {-# OVERLAPS #-} 71 | (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') 72 | => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where 73 | addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b 74 | 75 | -- | for @servant <0.11@ 76 | instance 77 | AddSetCookies ('S n) Application Application where 78 | addSetCookies cookies r request respond 79 | = r request $ respond . mapResponseHeaders (++ mkHeaders cookies) 80 | 81 | -- | for @servant >=0.11@ 82 | instance 83 | AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where 84 | addSetCookies cookies r = Tagged $ \request respond -> 85 | unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies) 86 | 87 | mkHeaders :: SetCookieList x -> [HTTP.Header] 88 | mkHeaders x = ("Set-Cookie",) <$> mkCookies x 89 | where 90 | mkCookies :: forall y. SetCookieList y -> [BS.ByteString] 91 | mkCookies SetCookieNil = [] 92 | mkCookies (SetCookieCons Nothing rest) = mkCookies rest 93 | mkCookies (SetCookieCons (Just y) rest) 94 | = toByteString (renderSetCookie y) : mkCookies rest 95 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Servant.Auth.Server.Internal.BasicAuth where 3 | 4 | #if !MIN_VERSION_servant_server(0,16,0) 5 | #define ServerError ServantErr 6 | #endif 7 | 8 | import qualified Data.ByteString as BS 9 | import Servant (BasicAuthData (..), 10 | ServerError (..), err401) 11 | import Servant.Server.Internal.BasicAuth (decodeBAHdr, 12 | mkBAChallengerHdr) 13 | 14 | import Servant.Auth.Server.Internal.Types 15 | 16 | -- | A 'ServerError' that asks the client to authenticate via Basic 17 | -- Authentication, should be invoked by an application whenever 18 | -- appropriate. The argument is the realm. 19 | wwwAuthenticatedErr :: BS.ByteString -> ServerError 20 | wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } 21 | 22 | -- | A type holding the configuration for Basic Authentication. 23 | -- It is defined as a type family with no arguments, so that 24 | -- it can be instantiated to whatever type you need to 25 | -- authenticate your users (use @type instance BasicAuthCfg = ...@). 26 | -- 27 | -- Note that the instantiation is application-wide, 28 | -- i.e. there can be only one instance. 29 | -- As a consequence, it should not be instantiated in a library. 30 | -- 31 | -- Basic Authentication expects an element of type 'BasicAuthCfg' 32 | -- to be in the 'Context'; that element is then passed automatically 33 | -- to the instance of 'FromBasicAuthData' together with the 34 | -- authentication data obtained from the client. 35 | -- 36 | -- If you do not need a configuration for Basic Authentication, 37 | -- you can use just @BasicAuthCfg = ()@, and recall to also 38 | -- add @()@ to the 'Context'. 39 | -- A basic but more interesting example is to take as 'BasicAuthCfg' 40 | -- a list of authorised username/password pairs: 41 | -- 42 | -- > deriving instance Eq BasicAuthData 43 | -- > type instance BasicAuthCfg = [BasicAuthData] 44 | -- > instance FromBasicAuthData User where 45 | -- > fromBasicAuthData authData authCfg = 46 | -- > if elem authData authCfg then ... 47 | type family BasicAuthCfg 48 | 49 | class FromBasicAuthData a where 50 | -- | Whether the username exists and the password is correct. 51 | -- Note that, rather than passing a 'Pass' to the function, we pass a 52 | -- function that checks an 'EncryptedPass'. This is to make sure you don't 53 | -- accidentally do something untoward with the password, like store it. 54 | fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a) 55 | 56 | basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr 57 | basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of 58 | Nothing -> return Indefinite 59 | Just baData -> fromBasicAuthData baData cfg 60 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Servant.Auth.Server.Internal.Class where 3 | 4 | import Servant.Auth 5 | import Data.Monoid 6 | import Servant hiding (BasicAuth) 7 | 8 | import Servant.Auth.JWT 9 | import Servant.Auth.Server.Internal.Types 10 | import Servant.Auth.Server.Internal.ConfigTypes 11 | import Servant.Auth.Server.Internal.BasicAuth 12 | import Servant.Auth.Server.Internal.Cookie 13 | import Servant.Auth.Server.Internal.JWT (jwtAuthCheck) 14 | 15 | -- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all 16 | -- elements of @ctx@ to be the in the Context and whose authentication check 17 | -- returns an @AuthCheck v@. 18 | class IsAuth a v where 19 | type family AuthArgs a :: [*] 20 | runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) 21 | 22 | instance FromJWT usr => IsAuth Cookie usr where 23 | type AuthArgs Cookie = '[CookieSettings, JWTSettings] 24 | runAuth _ _ = cookieAuthCheck 25 | 26 | instance FromJWT usr => IsAuth JWT usr where 27 | type AuthArgs JWT = '[JWTSettings] 28 | runAuth _ _ = jwtAuthCheck 29 | 30 | instance FromBasicAuthData usr => IsAuth BasicAuth usr where 31 | type AuthArgs BasicAuth = '[BasicAuthCfg] 32 | runAuth _ _ = basicAuthCheck 33 | 34 | -- * Helper 35 | 36 | class AreAuths (as :: [*]) (ctxs :: [*]) v where 37 | runAuths :: proxy as -> Context ctxs -> AuthCheck v 38 | 39 | instance AreAuths '[] ctxs v where 40 | runAuths _ _ = mempty 41 | 42 | instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) 43 | , IsAuth a v 44 | , AreAuths as ctxs v 45 | , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) 46 | ) => AreAuths (a ': as) ctxs v where 47 | runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs 48 | where 49 | go = appCtx (Proxy :: Proxy (AuthArgs a)) 50 | ctxs 51 | (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v)) 52 | 53 | type family Unapp ls res where 54 | Unapp '[] res = res 55 | Unapp (arg1 ': rest) res = arg1 -> Unapp rest res 56 | 57 | type family App ls res where 58 | App '[] res = res 59 | App (arg1 ': rest) (arg1 -> res) = App rest res 60 | 61 | -- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the 62 | -- values from the Context provided. 63 | class AppCtx ctx ls res where 64 | appCtx :: proxy ls -> Context ctx -> res -> App ls res 65 | 66 | instance ( HasContextEntry ctxs ctx 67 | , AppCtx ctxs rest res 68 | ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where 69 | appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx 70 | 71 | instance AppCtx ctx '[] res where 72 | appCtx _ _ r = r 73 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Server.Internal.ConfigTypes 2 | ( module Servant.Auth.Server.Internal.ConfigTypes 3 | , Servant.API.IsSecure(..) 4 | ) where 5 | 6 | import Crypto.JOSE as Jose 7 | import Crypto.JWT as Jose 8 | import qualified Data.ByteString as BS 9 | import Data.Default.Class 10 | import Data.Time 11 | import GHC.Generics (Generic) 12 | import Servant.API (IsSecure(..)) 13 | 14 | data IsMatch = Matches | DoesNotMatch 15 | deriving (Eq, Show, Read, Generic, Ord) 16 | 17 | data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect 18 | deriving (Eq, Show, Read, Generic, Ord) 19 | 20 | -- The @SameSite@ attribute of cookies determines whether cookies will be sent 21 | -- on cross-origin requests. 22 | -- 23 | -- See 24 | -- for more information. 25 | data SameSite = AnySite | SameSiteStrict | SameSiteLax 26 | deriving (Eq, Show, Read, Generic, Ord) 27 | 28 | -- | @JWTSettings@ are used to generate cookies, and to verify JWTs. 29 | data JWTSettings = JWTSettings 30 | { 31 | -- | Key used to sign JWT. 32 | signingKey :: Jose.JWK 33 | -- | Algorithm used to sign JWT. 34 | , jwtAlg :: Maybe Jose.Alg 35 | -- | Keys used to validate JWT. 36 | , validationKeys :: Jose.JWKSet 37 | -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the 38 | -- intended recipient of the JWT. 39 | , audienceMatches :: Jose.StringOrURI -> IsMatch 40 | } deriving (Generic) 41 | 42 | -- | A @JWTSettings@ where the audience always matches. 43 | defaultJWTSettings :: Jose.JWK -> JWTSettings 44 | defaultJWTSettings k = JWTSettings 45 | { signingKey = k 46 | , jwtAlg = Nothing 47 | , validationKeys = Jose.JWKSet [k] 48 | , audienceMatches = const Matches } 49 | 50 | -- | The policies to use when generating cookies. 51 | -- 52 | -- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will 53 | -- treat the cookie as a *session cookie*. These will be deleted when the 54 | -- browser is closed. 55 | -- 56 | -- Note that having the setting @Secure@ may cause testing failures if you are 57 | -- not testing over HTTPS. 58 | data CookieSettings = CookieSettings 59 | { 60 | -- | 'Secure' means browsers will only send cookies over HTTPS. Default: 61 | -- @Secure@. 62 | cookieIsSecure :: !IsSecure 63 | -- | How long from now until the cookie expires. Default: @Nothing@. 64 | , cookieMaxAge :: !(Maybe DiffTime) 65 | -- | At what time the cookie expires. Default: @Nothing@. 66 | , cookieExpires :: !(Maybe UTCTime) 67 | -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. 68 | , cookiePath :: !(Maybe BS.ByteString) 69 | -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@. 70 | , cookieDomain :: !(Maybe BS.ByteString) 71 | -- | 'SameSite' settings. Default: @SameSiteLax@. 72 | , cookieSameSite :: !SameSite 73 | -- | What name to use for the cookie used for the session. 74 | , sessionCookieName :: !BS.ByteString 75 | -- | The optional settings to use for XSRF protection. Default: @Just def@. 76 | , cookieXsrfSetting :: !(Maybe XsrfCookieSettings) 77 | } deriving (Eq, Show, Generic) 78 | 79 | instance Default CookieSettings where 80 | def = defaultCookieSettings 81 | 82 | defaultCookieSettings :: CookieSettings 83 | defaultCookieSettings = CookieSettings 84 | { cookieIsSecure = Secure 85 | , cookieMaxAge = Nothing 86 | , cookieExpires = Nothing 87 | , cookiePath = Just "/" 88 | , cookieDomain = Nothing 89 | , cookieSameSite = SameSiteLax 90 | , sessionCookieName = "JWT-Cookie" 91 | , cookieXsrfSetting = Just def 92 | } 93 | 94 | -- | The policies to use when generating and verifying XSRF cookies 95 | data XsrfCookieSettings = XsrfCookieSettings 96 | { 97 | -- | What name to use for the cookie used for XSRF protection. 98 | xsrfCookieName :: !BS.ByteString 99 | -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@. 100 | , xsrfCookiePath :: !(Maybe BS.ByteString) 101 | -- | What name to use for the header used for XSRF protection. 102 | , xsrfHeaderName :: !BS.ByteString 103 | -- | Exclude GET request method from XSRF protection. 104 | , xsrfExcludeGet :: !Bool 105 | } deriving (Eq, Show, Generic) 106 | 107 | instance Default XsrfCookieSettings where 108 | def = defaultXsrfCookieSettings 109 | 110 | defaultXsrfCookieSettings :: XsrfCookieSettings 111 | defaultXsrfCookieSettings = XsrfCookieSettings 112 | { xsrfCookieName = "XSRF-TOKEN" 113 | , xsrfCookiePath = Just "/" 114 | , xsrfHeaderName = "X-XSRF-TOKEN" 115 | , xsrfExcludeGet = False 116 | } 117 | 118 | ------------------------------------------------------------------------------ 119 | -- Internal {{{ 120 | 121 | jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings 122 | jwtSettingsToJwtValidationSettings s 123 | = defaultJWTValidationSettings (toBool <$> audienceMatches s) 124 | where 125 | toBool Matches = True 126 | toBool DoesNotMatch = False 127 | -- }}} 128 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Servant.Auth.Server.Internal.Cookie where 3 | 4 | import Blaze.ByteString.Builder (toByteString) 5 | import Control.Monad.Except 6 | import Control.Monad.Reader 7 | import qualified Crypto.JOSE as Jose 8 | import qualified Crypto.JWT as Jose 9 | import Data.ByteArray (constEq) 10 | import qualified Data.ByteString as BS 11 | import qualified Data.ByteString.Base64 as BS64 12 | import qualified Data.ByteString.Lazy as BSL 13 | import Data.CaseInsensitive (mk) 14 | import Data.Maybe (fromMaybe) 15 | import Data.Time.Calendar (Day(..)) 16 | import Data.Time.Clock (UTCTime(..), secondsToDiffTime) 17 | import Network.HTTP.Types (methodGet) 18 | import Network.HTTP.Types.Header(hCookie) 19 | import Network.Wai (Request, requestHeaders, requestMethod) 20 | import Servant (AddHeader, addHeader) 21 | import System.Entropy (getEntropy) 22 | import Web.Cookie 23 | 24 | import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT) 25 | import Servant.Auth.Server.Internal.ConfigTypes 26 | import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) 27 | import Servant.Auth.Server.Internal.Types 28 | 29 | 30 | cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr 31 | cookieAuthCheck ccfg jwtSettings = do 32 | req <- ask 33 | jwtCookie <- maybe mempty return $ do 34 | cookies' <- lookup hCookie $ requestHeaders req 35 | let cookies = parseCookies cookies' 36 | -- Apply the XSRF check if enabled. 37 | guard $ fromMaybe True $ do 38 | xsrfCookieCfg <- xsrfCheckRequired ccfg req 39 | return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies 40 | -- session cookie *must* be HttpOnly and Secure 41 | lookup (sessionCookieName ccfg) cookies 42 | verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie 43 | case verifiedJWT of 44 | Nothing -> mzero 45 | Just v -> return v 46 | 47 | xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings 48 | xsrfCheckRequired cookieSettings req = do 49 | xsrfCookieCfg <- cookieXsrfSetting cookieSettings 50 | let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet 51 | guard $ not disableForGetReq 52 | return xsrfCookieCfg 53 | 54 | xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool 55 | xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do 56 | xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies 57 | xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req 58 | return $ xsrfCookie `constEq` xsrfHeader 59 | 60 | -- | Makes a cookie to be used for XSRF. 61 | makeXsrfCookie :: CookieSettings -> IO SetCookie 62 | makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of 63 | Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings 64 | Nothing -> return $ noXsrfTokenCookie cookieSettings 65 | where 66 | makeRealCookie xsrfCookieSettings = do 67 | xsrfValue <- BS64.encode <$> getEntropy 32 68 | return 69 | $ applyXsrfCookieSettings xsrfCookieSettings 70 | $ applyCookieSettings cookieSettings 71 | $ def{ setCookieValue = xsrfValue } 72 | 73 | 74 | -- | Alias for 'makeXsrfCookie'. 75 | makeCsrfCookie :: CookieSettings -> IO SetCookie 76 | makeCsrfCookie = makeXsrfCookie 77 | {-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-} 78 | 79 | 80 | -- | Makes a cookie with session information. 81 | makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) 82 | makeSessionCookie cookieSettings jwtSettings v = do 83 | ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings) 84 | case ejwt of 85 | Left _ -> return Nothing 86 | Right jwt -> return 87 | $ Just 88 | $ applySessionCookieSettings cookieSettings 89 | $ applyCookieSettings cookieSettings 90 | $ def{ setCookieValue = BSL.toStrict jwt } 91 | 92 | noXsrfTokenCookie :: CookieSettings -> SetCookie 93 | noXsrfTokenCookie cookieSettings = 94 | applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" } 95 | 96 | applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie 97 | applyCookieSettings cookieSettings setCookie = setCookie 98 | { setCookieMaxAge = cookieMaxAge cookieSettings 99 | , setCookieExpires = cookieExpires cookieSettings 100 | , setCookiePath = cookiePath cookieSettings 101 | , setCookieDomain = cookieDomain cookieSettings 102 | , setCookieSecure = case cookieIsSecure cookieSettings of 103 | Secure -> True 104 | NotSecure -> False 105 | } 106 | 107 | applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie 108 | applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie 109 | { setCookieName = xsrfCookieName xsrfCookieSettings 110 | , setCookiePath = xsrfCookiePath xsrfCookieSettings 111 | , setCookieHttpOnly = False 112 | } 113 | 114 | applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie 115 | applySessionCookieSettings cookieSettings setCookie = setCookie 116 | { setCookieName = sessionCookieName cookieSettings 117 | , setCookieSameSite = case cookieSameSite cookieSettings of 118 | AnySite -> anySite 119 | SameSiteStrict -> Just sameSiteStrict 120 | SameSiteLax -> Just sameSiteLax 121 | , setCookieHttpOnly = True 122 | } 123 | where 124 | #if MIN_VERSION_cookie(0,4,5) 125 | anySite = Just sameSiteNone 126 | #else 127 | anySite = Nothing 128 | #endif 129 | 130 | -- | For a JWT-serializable session, returns a function that decorates a 131 | -- provided response object with XSRF and session cookies. This should be used 132 | -- when a user successfully authenticates with credentials. 133 | acceptLogin :: ( ToJWT session 134 | , AddHeader "Set-Cookie" SetCookie response withOneCookie 135 | , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) 136 | => CookieSettings 137 | -> JWTSettings 138 | -> session 139 | -> IO (Maybe (response -> withTwoCookies)) 140 | acceptLogin cookieSettings jwtSettings session = do 141 | mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session 142 | case mSessionCookie of 143 | Nothing -> pure Nothing 144 | Just sessionCookie -> do 145 | xsrfCookie <- makeXsrfCookie cookieSettings 146 | return $ Just $ addHeader sessionCookie . addHeader xsrfCookie 147 | 148 | -- | Arbitrary cookie expiry time set back in history after unix time 0 149 | expireTime :: UTCTime 150 | expireTime = UTCTime (ModifiedJulianDay 50000) 0 151 | 152 | -- | Adds headers to a response that clears all session cookies 153 | -- | using max-age and expires cookie attributes. 154 | clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie 155 | , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) 156 | => CookieSettings 157 | -> response 158 | -> withTwoCookies 159 | clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie 160 | where 161 | -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both 162 | cookieSettingsExpires = cookieSettings 163 | { cookieExpires = Just expireTime 164 | , cookieMaxAge = Just (secondsToDiffTime 0) 165 | } 166 | clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def 167 | clearedXsrfCookie = case cookieXsrfSetting cookieSettings of 168 | Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def 169 | Nothing -> noXsrfTokenCookie cookieSettingsExpires 170 | 171 | makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) 172 | makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c 173 | 174 | -- | Alias for 'makeSessionCookie'. 175 | makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) 176 | makeCookie = makeSessionCookie 177 | {-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-} 178 | 179 | -- | Alias for 'makeSessionCookieBS'. 180 | makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) 181 | makeCookieBS = makeSessionCookieBS 182 | {-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-} 183 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Server.Internal.FormLogin where 2 | 3 | 4 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Server.Internal.JWT where 2 | 3 | import Control.Lens 4 | import Control.Monad.Except 5 | import Control.Monad.Reader 6 | import qualified Crypto.JOSE as Jose 7 | import qualified Crypto.JWT as Jose 8 | import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, 9 | toJSON) 10 | import Data.ByteArray (constEq) 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Lazy as BSL 13 | import qualified Data.HashMap.Strict as HM 14 | import Data.Maybe (fromMaybe) 15 | import qualified Data.Text as T 16 | import Data.Time (UTCTime) 17 | import Network.Wai (requestHeaders) 18 | 19 | import Servant.Auth.JWT (FromJWT(..), ToJWT(..)) 20 | import Servant.Auth.Server.Internal.ConfigTypes 21 | import Servant.Auth.Server.Internal.Types 22 | 23 | 24 | -- | A JWT @AuthCheck@. You likely won't need to use this directly unless you 25 | -- are protecting a @Raw@ endpoint. 26 | jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr 27 | jwtAuthCheck jwtSettings = do 28 | req <- ask 29 | token <- maybe mempty return $ do 30 | authHdr <- lookup "Authorization" $ requestHeaders req 31 | let bearer = "Bearer " 32 | (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr 33 | guard (mbearer `constEq` bearer) 34 | return rest 35 | verifiedJWT <- liftIO $ verifyJWT jwtSettings token 36 | case verifiedJWT of 37 | Nothing -> mzero 38 | Just v -> return v 39 | 40 | -- | Creates a JWT containing the specified data. The data is stored in the 41 | -- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the 42 | -- token expires. 43 | makeJWT :: ToJWT a 44 | => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) 45 | makeJWT v cfg expiry = runExceptT $ do 46 | bestAlg <- Jose.bestJWSAlg $ signingKey cfg 47 | let alg = fromMaybe bestAlg $ jwtAlg cfg 48 | ejwt <- Jose.signClaims (signingKey cfg) 49 | (Jose.newJWSHeader ((), alg)) 50 | (addExp $ encodeJWT v) 51 | 52 | return $ Jose.encodeCompact ejwt 53 | where 54 | addExp claims = case expiry of 55 | Nothing -> claims 56 | Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e 57 | 58 | 59 | verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) 60 | verifyJWT jwtCfg input = do 61 | verifiedJWT <- liftIO $ runExceptT $ do 62 | unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input) 63 | Jose.verifyClaims 64 | (jwtSettingsToJwtValidationSettings jwtCfg) 65 | (validationKeys jwtCfg) 66 | unverifiedJWT 67 | return $ case verifiedJWT of 68 | Left (_ :: Jose.JWTError) -> Nothing 69 | Right v -> case decodeJWT v of 70 | Left _ -> Nothing 71 | Right v' -> Just v' -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Servant.Auth.Server.Internal.ThrowAll where 4 | 5 | #if !MIN_VERSION_servant_server(0,16,0) 6 | #define ServerError ServantErr 7 | #endif 8 | 9 | import Control.Monad.Error.Class 10 | import Data.Tagged (Tagged (..)) 11 | import Servant ((:<|>) (..), ServerError(..)) 12 | import Network.HTTP.Types 13 | import Network.Wai 14 | 15 | import qualified Data.ByteString.Char8 as BS 16 | 17 | class ThrowAll a where 18 | -- | 'throwAll' is a convenience function to throw errors across an entire 19 | -- sub-API 20 | -- 21 | -- 22 | -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c 23 | -- > == throwError err400 :<|> throwError err400 :<|> err400 24 | throwAll :: ServerError -> a 25 | 26 | instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where 27 | throwAll e = throwAll e :<|> throwAll e 28 | 29 | -- Really this shouldn't be necessary - ((->) a) should be an instance of 30 | -- MonadError, no? 31 | instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where 32 | throwAll e = const $ throwAll e 33 | 34 | instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where 35 | throwAll = throwError 36 | 37 | -- | for @servant <0.11@ 38 | instance {-# OVERLAPPING #-} ThrowAll Application where 39 | throwAll e _req respond 40 | = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) 41 | (errHeaders e) 42 | (errBody e) 43 | 44 | -- | for @servant >=0.11@ 45 | instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where 46 | throwAll e = Tagged $ \_req respond -> 47 | respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) 48 | (errHeaders e) 49 | (errBody e) 50 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Servant.Auth.Server.Internal.Types where 3 | 4 | import Control.Applicative 5 | import Control.Monad.Reader 6 | import Control.Monad.Time 7 | import Data.Monoid (Monoid (..)) 8 | import Data.Semigroup (Semigroup (..)) 9 | import Data.Time (getCurrentTime) 10 | import GHC.Generics (Generic) 11 | import Network.Wai (Request) 12 | 13 | import qualified Control.Monad.Fail as Fail 14 | 15 | -- | The result of an authentication attempt. 16 | data AuthResult val 17 | = BadPassword 18 | | NoSuchUser 19 | -- | Authentication succeeded. 20 | | Authenticated val 21 | -- | If an authentication procedure cannot be carried out - if for example it 22 | -- expects a password and username in a header that is not present - 23 | -- @Indefinite@ is returned. This indicates that other authentication 24 | -- methods should be tried. 25 | | Indefinite 26 | deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable) 27 | 28 | instance Semigroup (AuthResult val) where 29 | Indefinite <> y = y 30 | x <> _ = x 31 | 32 | instance Monoid (AuthResult val) where 33 | mempty = Indefinite 34 | mappend = (<>) 35 | 36 | instance Applicative AuthResult where 37 | pure = return 38 | (<*>) = ap 39 | 40 | instance Monad AuthResult where 41 | return = Authenticated 42 | Authenticated v >>= f = f v 43 | BadPassword >>= _ = BadPassword 44 | NoSuchUser >>= _ = NoSuchUser 45 | Indefinite >>= _ = Indefinite 46 | 47 | instance Alternative AuthResult where 48 | empty = mzero 49 | (<|>) = mplus 50 | 51 | instance MonadPlus AuthResult where 52 | mzero = mempty 53 | mplus = (<>) 54 | 55 | 56 | -- | An @AuthCheck@ is the function used to decide the authentication status 57 | -- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a 58 | -- Monoid or Alternative; the semantics of this is that the *first* 59 | -- non-'Indefinite' result from left to right is used and the rest are ignored. 60 | newtype AuthCheck val = AuthCheck 61 | { runAuthCheck :: Request -> IO (AuthResult val) } 62 | deriving (Generic, Functor) 63 | 64 | instance Semigroup (AuthCheck val) where 65 | AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do 66 | fx <- f x 67 | case fx of 68 | Indefinite -> g x 69 | r -> pure r 70 | 71 | instance Monoid (AuthCheck val) where 72 | mempty = AuthCheck $ const $ return mempty 73 | mappend = (<>) 74 | 75 | instance Applicative AuthCheck where 76 | pure = return 77 | (<*>) = ap 78 | 79 | instance Monad AuthCheck where 80 | return = AuthCheck . return . return . return 81 | AuthCheck ac >>= f = AuthCheck $ \req -> do 82 | aresult <- ac req 83 | case aresult of 84 | Authenticated usr -> runAuthCheck (f usr) req 85 | BadPassword -> return BadPassword 86 | NoSuchUser -> return NoSuchUser 87 | Indefinite -> return Indefinite 88 | 89 | #if !MIN_VERSION_base(4,13,0) 90 | fail = Fail.fail 91 | #endif 92 | 93 | instance Fail.MonadFail AuthCheck where 94 | fail _ = AuthCheck . const $ return Indefinite 95 | 96 | instance MonadReader Request AuthCheck where 97 | ask = AuthCheck $ \x -> return (Authenticated x) 98 | local f (AuthCheck check) = AuthCheck $ \req -> check (f req) 99 | 100 | instance MonadIO AuthCheck where 101 | liftIO action = AuthCheck $ const $ Authenticated <$> action 102 | 103 | instance MonadTime AuthCheck where 104 | currentTime = liftIO getCurrentTime 105 | 106 | instance Alternative AuthCheck where 107 | empty = mzero 108 | (<|>) = mplus 109 | 110 | instance MonadPlus AuthCheck where 111 | mzero = mempty 112 | mplus = (<>) 113 | -------------------------------------------------------------------------------- /servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.Server.SetCookieOrphan 2 | {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-} 3 | () where 4 | -------------------------------------------------------------------------------- /servant-auth-server/test/Servant/Auth/ServerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Servant.Auth.ServerSpec (spec) where 3 | 4 | #if !MIN_VERSION_servant_server(0,16,0) 5 | #define ServerError ServantErr 6 | #endif 7 | 8 | import Control.Lens 9 | import Control.Monad.Except (runExceptT) 10 | import Control.Monad.IO.Class (liftIO) 11 | import Crypto.JOSE (Alg (HS256, None), Error, 12 | JWK, JWSHeader, 13 | KeyMaterialGenParam (OctGenParam), 14 | ToCompact, encodeCompact, 15 | genJWK, newJWSHeader) 16 | import Crypto.JWT (Audience (..), ClaimsSet, 17 | NumericDate (NumericDate), 18 | SignedJWT, 19 | claimAud, claimNbf, 20 | signClaims, 21 | emptyClaimsSet, 22 | unregisteredClaims) 23 | import Data.Aeson (FromJSON, ToJSON, Value, 24 | toJSON, encode) 25 | import Data.Aeson.Lens (_JSON) 26 | import qualified Data.ByteString as BS 27 | import qualified Data.ByteString.Lazy as BSL 28 | import Data.CaseInsensitive (mk) 29 | import Data.Foldable (find) 30 | import Data.Monoid 31 | import Data.Time 32 | import Data.Time.Clock (getCurrentTime) 33 | import GHC.Generics (Generic) 34 | import Network.HTTP.Client (cookie_http_only, 35 | cookie_name, cookie_value, 36 | cookie_expiry_time, 37 | destroyCookieJar) 38 | import Network.HTTP.Types (Status, status200, 39 | status401) 40 | import Network.Wai (responseLBS) 41 | import Network.Wai.Handler.Warp (testWithApplication) 42 | import Network.Wreq (Options, auth, basicAuth, 43 | cookieExpiryTime, cookies, 44 | defaults, get, getWith, postWith, 45 | header, oauth2Bearer, 46 | responseBody, 47 | responseCookieJar, 48 | responseHeader, 49 | responseStatus) 50 | import Network.Wreq.Types (Postable(..)) 51 | import Servant hiding (BasicAuth, 52 | IsSecure (..), header) 53 | import Servant.Auth.Server 54 | import Servant.Auth.Server.Internal.Cookie (expireTime) 55 | import Servant.Auth.Server.SetCookieOrphan () 56 | #if MIN_VERSION_servant_server(0,15,0) 57 | import qualified Servant.Types.SourceT as S 58 | #endif 59 | import System.IO.Unsafe (unsafePerformIO) 60 | import Test.Hspec 61 | import Test.QuickCheck 62 | import qualified Network.HTTP.Client as HCli 63 | 64 | 65 | 66 | spec :: Spec 67 | spec = do 68 | authSpec 69 | cookieAuthSpec 70 | jwtAuthSpec 71 | throwAllSpec 72 | basicAuthSpec 73 | 74 | ------------------------------------------------------------------------------ 75 | -- * Auth {{{ 76 | 77 | authSpec :: Spec 78 | authSpec 79 | = describe "The Auth combinator" 80 | $ around (testWithApplication . return $ app jwtAndCookieApi) $ do 81 | 82 | it "returns a 401 if all authentications are Indefinite" $ \port -> do 83 | get (url port) `shouldHTTPErrorWith` status401 84 | 85 | it "succeeds if one authentication suceeds" $ \port -> property $ 86 | \(user :: User) -> do 87 | jwt <- makeJWT user jwtCfg Nothing 88 | opts <- addJwtToHeader jwt 89 | resp <- getWith opts (url port) 90 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 91 | 92 | it "fails (403) if one authentication fails" $ const $ 93 | pendingWith "Authentications don't yet fail, only are Indefinite" 94 | 95 | it "doesn't clobber pre-existing response headers" $ \port -> property $ 96 | \(user :: User) -> do 97 | jwt <- makeJWT user jwtCfg Nothing 98 | opts <- addJwtToHeader jwt 99 | resp <- getWith opts (url port ++ "/header") 100 | resp ^. responseHeader "Blah" `shouldBe` "1797" 101 | resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") 102 | 103 | context "Raw" $ do 104 | 105 | it "gets the response body" $ \port -> property $ \(user :: User) -> do 106 | jwt <- makeJWT user jwtCfg Nothing 107 | opts <- addJwtToHeader jwt 108 | resp <- getWith opts (url port ++ "/raw") 109 | resp ^. responseBody `shouldBe` "how are you?" 110 | 111 | it "doesn't clobber pre-existing reponse headers" $ \port -> property $ 112 | \(user :: User) -> do 113 | jwt <- makeJWT user jwtCfg Nothing 114 | opts <- addJwtToHeader jwt 115 | resp <- getWith opts (url port ++ "/raw") 116 | resp ^. responseHeader "hi" `shouldBe` "there" 117 | resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") 118 | 119 | 120 | context "Setting cookies" $ do 121 | 122 | it "sets cookies that it itself accepts" $ \port -> property $ \user -> do 123 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 124 | (claims $ toJSON user) 125 | opts' <- addJwtToCookie cookieCfg jwt 126 | let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) 127 | (xsrfField xsrfCookieName cookieCfg <> "=blah") 128 | resp <- getWith opts (url port) 129 | let (cookieJar:_) = resp ^.. responseCookieJar 130 | Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) 131 | $ destroyCookieJar cookieJar 132 | opts2 = defaults 133 | & cookies .~ Just cookieJar 134 | & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] 135 | resp2 <- getWith opts2 (url port) 136 | resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user) 137 | 138 | it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do 139 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 140 | (claims $ toJSON user) 141 | opts' <- addJwtToCookie cookieCfg jwt 142 | let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) 143 | (xsrfField xsrfCookieName cookieCfg <> "=blah") 144 | resp <- getWith opts (url port) 145 | let (cookieJar:_) = resp ^.. responseCookieJar 146 | Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) 147 | $ destroyCookieJar cookieJar 148 | xxsrf ^. cookieExpiryTime `shouldBe` future 149 | 150 | it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do 151 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 152 | (claims $ toJSON user) 153 | opts' <- addJwtToCookie cookieCfg jwt 154 | let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) 155 | (xsrfField xsrfCookieName cookieCfg <> "=blah") 156 | resp <- getWith opts (url port) 157 | let (cookieJar:_) = resp ^.. responseCookieJar 158 | Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg) 159 | $ destroyCookieJar cookieJar 160 | cookie_http_only token `shouldBe` True 161 | 162 | 163 | 164 | -- }}} 165 | ------------------------------------------------------------------------------ 166 | -- * Cookie Auth {{{ 167 | 168 | cookieAuthSpec :: Spec 169 | cookieAuthSpec 170 | = describe "The Auth combinator" $ do 171 | describe "With XSRF check" $ 172 | around (testWithApplication . return $ app cookieOnlyApi) $ do 173 | 174 | it "fails if XSRF header and cookie don't match" $ \port -> property 175 | $ \(user :: User) -> do 176 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 177 | opts' <- addJwtToCookie cookieCfg jwt 178 | let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) 179 | (xsrfField xsrfCookieName cookieCfg <> "=blerg") 180 | getWith opts (url port) `shouldHTTPErrorWith` status401 181 | 182 | it "fails with no XSRF header or cookie" $ \port -> property 183 | $ \(user :: User) -> do 184 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 185 | opts <- addJwtToCookie cookieCfg jwt 186 | getWith opts (url port) `shouldHTTPErrorWith` status401 187 | 188 | it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property 189 | $ \(user :: User) -> do 190 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 191 | opts' <- addJwtToCookie cookieCfg jwt 192 | let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) 193 | (xsrfField xsrfCookieName cookieCfg <> "=blah") 194 | resp <- getWith opts (url port) 195 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 196 | 197 | it "sets and clears the right cookies" $ \port -> property 198 | $ \(user :: User) -> do 199 | let optsFromResp resp = 200 | let jar = resp ^. responseCookieJar 201 | Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) 202 | in defaults 203 | & cookies .~ Just jar -- real cookie jars aren't updated by being replaced 204 | & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] 205 | 206 | resp <- postWith defaults (url port ++ "/login") user 207 | (resp ^. responseCookieJar) `shouldMatchCookieNames` 208 | [ sessionCookieName cookieCfg 209 | , xsrfField xsrfCookieName cookieCfg 210 | ] 211 | let loggedInOpts = optsFromResp resp 212 | 213 | resp <- getWith loggedInOpts (url port) 214 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 215 | 216 | -- logout 217 | resp <- getWith loggedInOpts (url port ++ "/logout") 218 | 219 | -- assert cookies were expired 220 | now <- getCurrentTime 221 | let assertCookie c = now >= cookie_expiry_time c 222 | all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True 223 | 224 | let loggedOutOpts = optsFromResp resp 225 | getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 226 | 227 | describe "With no XSRF check for GET requests" $ let 228 | noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True } 229 | cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg } 230 | in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do 231 | 232 | it "succeeds with no XSRF header or cookie for GET" $ \port -> property 233 | $ \(user :: User) -> do 234 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 235 | opts <- addJwtToCookie cookieCfgNoXsrfGet jwt 236 | resp <- getWith opts (url port) 237 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 238 | 239 | it "fails with no XSRF header or cookie for POST" $ \port -> property 240 | $ \(user :: User) number -> do 241 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 242 | opts <- addJwtToCookie cookieCfgNoXsrfGet jwt 243 | postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 244 | 245 | describe "With no XSRF check at all" $ let 246 | cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing } 247 | in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do 248 | 249 | it "succeeds with no XSRF header or cookie for GET" $ \port -> property 250 | $ \(user :: User) -> do 251 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 252 | opts <- addJwtToCookie cookieCfgNoXsrf jwt 253 | resp <- getWith opts (url port) 254 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 255 | 256 | it "succeeds with no XSRF header or cookie for POST" $ \port -> property 257 | $ \(user :: User) number -> do 258 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) 259 | opts <- addJwtToCookie cookieCfgNoXsrf jwt 260 | resp <- postWith opts (url port) $ toJSON (number :: Int) 261 | resp ^? responseBody . _JSON `shouldBe` Just number 262 | 263 | it "sets and clears the right cookies" $ \port -> property 264 | $ \(user :: User) -> do 265 | let optsFromResp resp = defaults 266 | & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced 267 | 268 | resp <- postWith defaults (url port ++ "/login") user 269 | (resp ^. responseCookieJar) `shouldMatchCookieNames` 270 | [ sessionCookieName cookieCfg 271 | , "NO-XSRF-TOKEN" 272 | ] 273 | let loggedInOpts = optsFromResp resp 274 | 275 | resp <- getWith (loggedInOpts) (url port) 276 | resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) 277 | 278 | resp <- getWith loggedInOpts (url port ++ "/logout") 279 | (resp ^. responseCookieJar) `shouldMatchCookieNameValues` 280 | [ (sessionCookieName cookieCfg, "value") 281 | , ("NO-XSRF-TOKEN", "") 282 | ] 283 | 284 | -- assert cookies were expired 285 | now <- getCurrentTime 286 | let assertCookie c = now >= cookie_expiry_time c 287 | all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True 288 | 289 | let loggedOutOpts = optsFromResp resp 290 | 291 | getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 292 | 293 | -- }}} 294 | ------------------------------------------------------------------------------ 295 | -- * JWT Auth {{{ 296 | 297 | jwtAuthSpec :: Spec 298 | jwtAuthSpec 299 | = describe "The JWT combinator" 300 | $ around (testWithApplication . return $ app jwtOnlyApi) $ do 301 | 302 | it "fails if 'aud' does not match predicate" $ \port -> property $ 303 | \(user :: User) -> do 304 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 305 | (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) 306 | opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) 307 | getWith opts (url port) `shouldHTTPErrorWith` status401 308 | 309 | it "succeeds if 'aud' does match predicate" $ \port -> property $ 310 | \(user :: User) -> do 311 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 312 | (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) 313 | opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) 314 | resp <- getWith opts (url port) 315 | resp ^. responseStatus `shouldBe` status200 316 | 317 | it "fails if 'nbf' is set to a future date" $ \port -> property $ 318 | \(user :: User) -> do 319 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 320 | (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) 321 | opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) 322 | getWith opts (url port) `shouldHTTPErrorWith` status401 323 | 324 | it "fails if 'exp' is set to a past date" $ \port -> property $ 325 | \(user :: User) -> do 326 | jwt <- makeJWT user jwtCfg (Just past) 327 | opts <- addJwtToHeader jwt 328 | getWith opts (url port) `shouldHTTPErrorWith` status401 329 | 330 | it "succeeds if 'exp' is set to a future date" $ \port -> property $ 331 | \(user :: User) -> do 332 | jwt <- makeJWT user jwtCfg (Just future) 333 | opts <- addJwtToHeader jwt 334 | resp <- getWith opts (url port) 335 | resp ^. responseStatus `shouldBe` status200 336 | 337 | it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do 338 | jwt <- createJWT theKey (newJWSHeader ((), None)) 339 | (claims $ toJSON user) 340 | opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) 341 | getWith opts (url port) `shouldHTTPErrorWith` status401 342 | 343 | it "fails if JWT does not use expected algorithm" $ const $ 344 | pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" 345 | 346 | it "fails if data is not valid JSON" $ \port -> do 347 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{") 348 | opts <- addJwtToHeader (jwt >>= (return .encodeCompact)) 349 | getWith opts (url port) `shouldHTTPErrorWith` status401 350 | 351 | it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do 352 | jwt <- createJWT theKey (newJWSHeader ((), HS256)) 353 | (claims $ toJSON user) 354 | resp <- case jwt >>= (return . encodeCompact) of 355 | Left (e :: Error) -> fail $ show e 356 | Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) 357 | resp ^. responseStatus `shouldBe` status200 358 | 359 | -- }}} 360 | ------------------------------------------------------------------------------ 361 | -- * Basic Auth {{{ 362 | 363 | basicAuthSpec :: Spec 364 | basicAuthSpec = describe "The BasicAuth combinator" 365 | $ around (testWithApplication . return $ app basicAuthApi) $ do 366 | 367 | it "succeeds with the correct password and username" $ \port -> do 368 | resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) 369 | resp ^. responseStatus `shouldBe` status200 370 | 371 | it "fails with non-existent user" $ \port -> do 372 | getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port) 373 | `shouldHTTPErrorWith` status401 374 | 375 | it "fails with incorrect password" $ \port -> do 376 | getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port) 377 | `shouldHTTPErrorWith` status401 378 | 379 | it "fails with no auth header" $ \port -> do 380 | get (url port) `shouldHTTPErrorWith` status401 381 | 382 | -- }}} 383 | ------------------------------------------------------------------------------ 384 | -- * ThrowAll {{{ 385 | 386 | throwAllSpec :: Spec 387 | throwAllSpec = describe "throwAll" $ do 388 | 389 | it "works for plain values" $ do 390 | let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String 391 | t = throwAll err401 392 | t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401 393 | 394 | it "works for function types" $ property $ \i -> do 395 | let t :: Int -> (Either ServerError Bool :<|> Either ServerError String) 396 | t = throwAll err401 397 | expected _ = throwError err401 :<|> throwError err401 398 | t i `shouldBe` expected i 399 | 400 | -- }}} 401 | ------------------------------------------------------------------------------ 402 | -- * API and Server {{{ 403 | 404 | type API auths 405 | = Auth auths User :> 406 | ( Get '[JSON] Int 407 | :<|> ReqBody '[JSON] Int :> Post '[JSON] Int 408 | :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) 409 | #if MIN_VERSION_servant_server(0,15,0) 410 | :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) 411 | #endif 412 | :<|> "raw" :> Raw 413 | ) 414 | :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie 415 | , Header "Set-Cookie" SetCookie ] NoContent) 416 | :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie 417 | , Header "Set-Cookie" SetCookie ] NoContent) 418 | 419 | jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) 420 | jwtOnlyApi = Proxy 421 | 422 | cookieOnlyApi :: Proxy (API '[Cookie]) 423 | cookieOnlyApi = Proxy 424 | 425 | basicAuthApi :: Proxy (API '[BasicAuth]) 426 | basicAuthApi = Proxy 427 | 428 | jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie]) 429 | jwtAndCookieApi = Proxy 430 | 431 | theKey :: JWK 432 | theKey = unsafePerformIO . genJWK $ OctGenParam 256 433 | {-# NOINLINE theKey #-} 434 | 435 | 436 | cookieCfg :: CookieSettings 437 | cookieCfg = def 438 | { cookieExpires = Just future 439 | , cookieIsSecure = NotSecure 440 | , sessionCookieName = "RuncibleSpoon" 441 | , cookieXsrfSetting = pure $ def 442 | { xsrfCookieName = "TheyDinedOnMince" 443 | , xsrfHeaderName = "AndSlicesOfQuince" 444 | } 445 | } 446 | xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a 447 | xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting 448 | 449 | jwtCfg :: JWTSettings 450 | jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x -> 451 | if x == "boo" then DoesNotMatch else Matches } 452 | 453 | instance FromBasicAuthData User where 454 | fromBasicAuthData (BasicAuthData usr pwd) _ 455 | = return $ if usr == "ali" && pwd == "Open sesame" 456 | then Authenticated $ User "ali" "ali@the-thieves-den.com" 457 | else Indefinite 458 | 459 | -- Could be anything, really, but since this is already in the cfg we don't 460 | -- have to add it 461 | type instance BasicAuthCfg = JWK 462 | 463 | appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User 464 | => Proxy (API auths) -> CookieSettings -> Application 465 | appWithCookie api ccfg = serveWithContext api ctx $ server ccfg 466 | where 467 | ctx = ccfg :. jwtCfg :. theKey :. EmptyContext 468 | 469 | -- | Takes a proxy parameter indicating which authentication systems to enable. 470 | app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User 471 | => Proxy (API auths) -> Application 472 | app api = appWithCookie api cookieCfg 473 | 474 | server :: CookieSettings -> Server (API auths) 475 | server ccfg = 476 | (\authResult -> case authResult of 477 | Authenticated usr -> getInt usr 478 | :<|> postInt usr 479 | :<|> getHeaderInt 480 | #if MIN_VERSION_servant_server(0,15,0) 481 | :<|> return (S.source ["bytestring"]) 482 | #endif 483 | :<|> raw 484 | Indefinite -> throwAll err401 485 | _ -> throwAll err403 486 | ) 487 | :<|> getLogin 488 | :<|> getLogout 489 | where 490 | getInt :: User -> Handler Int 491 | getInt usr = return . length $ name usr 492 | 493 | postInt :: User -> Int -> Handler Int 494 | postInt _ = return 495 | 496 | getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int) 497 | getHeaderInt = return $ addHeader 1797 17 498 | 499 | getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie 500 | , Header "Set-Cookie" SetCookie ] NoContent) 501 | getLogin user = do 502 | maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user 503 | case maybeApplyCookies of 504 | Just applyCookies -> return $ applyCookies NoContent 505 | Nothing -> error "cookies failed to apply" 506 | 507 | getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie 508 | , Header "Set-Cookie" SetCookie ] NoContent) 509 | getLogout = return $ clearSession ccfg NoContent 510 | 511 | raw :: Server Raw 512 | raw = 513 | #if MIN_VERSION_servant_server(0,11,0) 514 | Tagged $ 515 | #endif 516 | \_req respond -> 517 | respond $ responseLBS status200 [("hi", "there")] "how are you?" 518 | 519 | -- }}} 520 | ------------------------------------------------------------------------------ 521 | -- * Utils {{{ 522 | 523 | past :: UTCTime 524 | past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01" 525 | 526 | future :: UTCTime 527 | future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01" 528 | 529 | addJwtToHeader :: Either Error BSL.ByteString -> IO Options 530 | addJwtToHeader jwt = case jwt of 531 | Left e -> fail $ show e 532 | Right v -> return 533 | $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] 534 | 535 | createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) 536 | createJWT k a b = runExceptT $ signClaims k a b 537 | 538 | addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options 539 | addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of 540 | Left e -> fail $ show e 541 | Right v -> return 542 | $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] 543 | 544 | addCookie :: Options -> BS.ByteString -> Options 545 | addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of 546 | [h] -> [cookie' <> "; " <> h] 547 | [] -> [cookie'] 548 | _ -> error "expecting single cookie header" 549 | 550 | 551 | shouldHTTPErrorWith :: IO a -> Status -> Expectation 552 | shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of 553 | #if MIN_VERSION_http_client(0,5,0) 554 | HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _) 555 | -> HCli.responseStatus resp == stat 556 | #else 557 | HCli.StatusCodeException x _ _ -> x == stat 558 | #endif 559 | _ -> False 560 | 561 | shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation 562 | shouldMatchCookieNames cj patterns 563 | = fmap cookie_name (destroyCookieJar cj) 564 | `shouldMatchList` patterns 565 | 566 | shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation 567 | shouldMatchCookieNameValues cj patterns 568 | = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj) 569 | `shouldMatchList` patterns 570 | 571 | url :: Int -> String 572 | url port = "http://localhost:" <> show port 573 | 574 | claims :: Value -> ClaimsSet 575 | claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val 576 | -- }}} 577 | ------------------------------------------------------------------------------ 578 | -- * Types {{{ 579 | 580 | data User = User 581 | { name :: String 582 | , _id :: String 583 | } deriving (Eq, Show, Read, Generic) 584 | 585 | instance FromJWT User 586 | instance ToJWT User 587 | instance FromJSON User 588 | instance ToJSON User 589 | 590 | instance Arbitrary User where 591 | arbitrary = User <$> arbitrary <*> arbitrary 592 | 593 | instance Postable User where 594 | postPayload user request = return $ request 595 | { HCli.requestBody = HCli.RequestBodyLBS $ encode user 596 | , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request 597 | } 598 | 599 | 600 | -- }}} 601 | -------------------------------------------------------------------------------- /servant-auth-server/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /servant-auth-swagger/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -idoctest/ghci-wrapper/src 2 | -------------------------------------------------------------------------------- /servant-auth-swagger/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 6 | and this project adheres to [PVP Versioning](https://pvp.haskell.org/). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.2.10.1] - 2020-10-06 11 | 12 | ### Changed 13 | 14 | - Support GHC 8.10 @domenkozar 15 | - Fix build with swagger 2.5.x @domenkozar 16 | 17 | ## [0.2.10.0] - 2018-06-18 18 | 19 | ### Added 20 | 21 | - Support for GHC 8.4 by @phadej 22 | - Changelog by @domenkozar 23 | - #93: Add Cookie in SwaggerSpec API by @domenkozar 24 | - #42: Add dummy AllHasSecurity Cookie instance by @sordina 25 | -------------------------------------------------------------------------------- /servant-auth-swagger/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Julian K. Arni (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julian K. Arni nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /servant-auth-swagger/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /servant-auth-swagger/servant-auth-swagger.cabal: -------------------------------------------------------------------------------- 1 | name: servant-auth-swagger 2 | version: 0.2.10.1 3 | synopsis: servant-swagger/servant-auth compatibility 4 | description: This package provides instances that allow generating swagger2 schemas from 5 | 6 | APIs that use 7 | @Auth@ combinator. 8 | . 9 | For a quick overview of the usage, see the . 10 | category: Web, Servant, Authentication 11 | homepage: http://github.com/haskell-servant/servant-auth#readme 12 | bug-reports: https://github.com/haskell-servant/servant-auth/issues 13 | author: Julian K. Arni 14 | maintainer: jkarni@gmail.com 15 | copyright: (c) Julian K. Arni 16 | license: BSD3 17 | license-file: LICENSE 18 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 19 | build-type: Simple 20 | cabal-version: >= 1.10 21 | extra-source-files: 22 | CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/haskell-servant/servant-auth 27 | 28 | library 29 | hs-source-dirs: 30 | src 31 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 32 | ghc-options: -Wall 33 | build-depends: 34 | base >= 4.10 && < 4.16 35 | , text >= 1.2.3.0 && < 1.3 36 | , servant-swagger >= 1.1.5 && < 1.8 37 | , swagger2 >= 2.2.2 && < 2.7 38 | , servant >= 0.13 && < 0.19 39 | , servant-auth == 0.4.* 40 | , lens >= 4.16.1 && < 5.1 41 | exposed-modules: 42 | Servant.Auth.Swagger 43 | default-language: Haskell2010 44 | 45 | test-suite spec 46 | type: exitcode-stdio-1.0 47 | main-is: Spec.hs 48 | hs-source-dirs: 49 | test 50 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 51 | ghc-options: -Wall 52 | build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9 53 | -- dependencies with bounds inherited from the library stanza 54 | build-depends: 55 | base 56 | , text 57 | , servant-swagger 58 | , swagger2 59 | , servant 60 | , servant-auth 61 | , lens 62 | 63 | -- test dependencies 64 | build-depends: 65 | servant-auth-swagger 66 | , hspec >= 2.5.5 && < 2.9 67 | , QuickCheck >= 2.11.3 && < 2.15 68 | other-modules: 69 | Servant.Auth.SwaggerSpec 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /servant-auth-swagger/src/Servant/Auth/Swagger.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | module Servant.Auth.Swagger 4 | ( 5 | -- | The purpose of this package is provide the instance for 'servant-auth' 6 | -- combinators needed for 'servant-swagger' documentation generation. 7 | -- 8 | -- Currently only JWT and BasicAuth are supported. 9 | 10 | -- * Re-export 11 | JWT 12 | , BasicAuth 13 | , Auth 14 | 15 | -- * Needed to define instances of @HasSwagger@ 16 | , HasSecurity (..) 17 | ) where 18 | 19 | import Control.Lens ((&), (<>~)) 20 | import Data.Proxy (Proxy (Proxy)) 21 | import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..), 22 | SecurityRequirement (..), SecurityScheme (..), 23 | #if MIN_VERSION_swagger2(2,6,0) 24 | SecurityDefinitions(..), 25 | #endif 26 | SecuritySchemeType (..), allOperations, security, 27 | securityDefinitions) 28 | import GHC.Exts (fromList) 29 | import Servant.API hiding (BasicAuth) 30 | import Servant.Auth 31 | import Servant.Swagger 32 | 33 | import qualified Data.Text as T 34 | 35 | instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where 36 | toSwagger _ 37 | = toSwagger (Proxy :: Proxy api) 38 | & securityDefinitions <>~ mkSec (fromList secs) 39 | & allOperations.security <>~ secReqs 40 | where 41 | secs = securities (Proxy :: Proxy xs) 42 | secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs] 43 | mkSec = 44 | #if MIN_VERSION_swagger2(2,6,0) 45 | SecurityDefinitions 46 | #else 47 | id 48 | #endif 49 | 50 | 51 | class HasSecurity x where 52 | securityName :: Proxy x -> T.Text 53 | securityScheme :: Proxy x -> SecurityScheme 54 | 55 | instance HasSecurity BasicAuth where 56 | securityName _ = "BasicAuth" 57 | securityScheme _ = SecurityScheme type_ (Just desc) 58 | where 59 | type_ = SecuritySchemeBasic 60 | desc = "Basic access authentication" 61 | 62 | instance HasSecurity JWT where 63 | securityName _ = "JwtSecurity" 64 | securityScheme _ = SecurityScheme type_ (Just desc) 65 | where 66 | type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader) 67 | desc = "JSON Web Token-based API key" 68 | 69 | class AllHasSecurity (x :: [*]) where 70 | securities :: Proxy x -> [(T.Text,SecurityScheme)] 71 | 72 | instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where 73 | securities _ = (securityName px, securityScheme px) : securities pxs 74 | where 75 | px :: Proxy x 76 | px = Proxy 77 | pxs :: Proxy xs 78 | pxs = Proxy 79 | 80 | instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where 81 | securities _ = securities pxs 82 | where 83 | pxs :: Proxy xs 84 | pxs = Proxy 85 | 86 | instance AllHasSecurity '[] where 87 | securities _ = [] 88 | -------------------------------------------------------------------------------- /servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Servant.Auth.SwaggerSpec (spec) where 3 | 4 | import Control.Lens 5 | import Data.Proxy 6 | import Servant.API 7 | import Servant.Auth 8 | import Servant.Auth.Swagger 9 | import Data.Swagger 10 | import Servant.Swagger 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = describe "HasSwagger instance" $ do 15 | 16 | let swag = toSwagger (Proxy :: Proxy API) 17 | 18 | it "adds security definitions at the top level" $ do 19 | #if MIN_VERSION_swagger2(2,6,0) 20 | let (SecurityDefinitions secDefs) = swag ^. securityDefinitions 21 | #else 22 | let secDefs = swag ^. securityDefinitions 23 | #endif 24 | length secDefs `shouldSatisfy` (> 0) 25 | 26 | it "adds security at sub-apis" $ do 27 | swag ^. security `shouldBe` [] 28 | show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity" 29 | show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity" 30 | 31 | -- * API 32 | 33 | type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI 34 | :<|> "insecure" :> InsecureAPI 35 | 36 | type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int 37 | 38 | type InsecureAPI = SecureAPI 39 | -------------------------------------------------------------------------------- /servant-auth-swagger/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /servant-auth/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -idoctest/ghci-wrapper/src 2 | -------------------------------------------------------------------------------- /servant-auth/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 6 | and this project adheres to [PVP Versioning](https://pvp.haskell.org/). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.4.0.0] - 2020-10-06 11 | 12 | - Support for GHC 8.10 by @domenkozar 13 | - Support servant 0.18 by @domenkozar 14 | - Move `ToJWT/FromJWT` from servant-auth-server 15 | 16 | ## [0.3.2.0] - 2018-06-18 17 | 18 | ### Added 19 | - Support for GHC 8.4 by @phadej 20 | - Changelog by @domenkozar 21 | -------------------------------------------------------------------------------- /servant-auth/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Julian K. Arni (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Julian K. Arni nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /servant-auth/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /servant-auth/servant-auth.cabal: -------------------------------------------------------------------------------- 1 | name: servant-auth 2 | version: 0.4.0.0 3 | synopsis: Authentication combinators for servant 4 | description: This package provides an @Auth@ combinator for 'servant'. This combinator 5 | allows using different authentication schemes in a straightforward way, 6 | and possibly in conjunction with one another. 7 | . 8 | 'servant-auth' additionally provides concrete authentication schemes, such 9 | as Basic Access Authentication, JSON Web Tokens, and Cookies. 10 | . 11 | For more details on how to use this, see the . 12 | category: Web, Servant, Authentication 13 | homepage: http://github.com/haskell-servant/servant-auth#readme 14 | bug-reports: https://github.com/haskell-servant/servant-auth/issues 15 | author: Julian K. Arni 16 | maintainer: jkarni@gmail.com 17 | copyright: (c) Julian K. Arni 18 | license: BSD3 19 | license-file: LICENSE 20 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 21 | build-type: Simple 22 | cabal-version: >= 1.10 23 | extra-source-files: 24 | CHANGELOG.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/haskell-servant/servant-auth 29 | 30 | library 31 | hs-source-dirs: 32 | src 33 | default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 34 | ghc-options: -Wall 35 | build-depends: 36 | base >= 4.10 && < 4.16 37 | , aeson >= 1.3.1.1 && < 1.6 38 | , jose >= 0.7.0.0 && < 0.9 39 | , lens >= 4.16.1 && < 5.1 40 | , servant >= 0.15 && < 0.19 41 | , text >= 1.2.3.0 && < 1.3 42 | , unordered-containers >= 0.2.9.0 && < 0.3 43 | exposed-modules: 44 | Servant.Auth 45 | Servant.Auth.JWT 46 | default-language: Haskell2010 47 | -------------------------------------------------------------------------------- /servant-auth/src/Servant/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | module Servant.Auth where 7 | 8 | import Data.Proxy (Proxy(..)) 9 | import Servant.API ((:>)) 10 | import Servant.Links (HasLink (..)) 11 | 12 | -- * Authentication 13 | 14 | -- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by 15 | -- @auth1@ or @auth2@ 16 | data Auth (auths :: [*]) val 17 | 18 | -- | A @HasLink@ instance for @Auth@ 19 | instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where 20 | #if MIN_VERSION_servant(0,14,0) 21 | type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a 22 | toLink toA _ = toLink toA (Proxy :: Proxy sub) 23 | #else 24 | type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub 25 | toLink _ = toLink (Proxy :: Proxy sub) 26 | #endif 27 | 28 | -- ** Combinators 29 | 30 | -- | A JSON Web Token (JWT) in the the Authorization header: 31 | -- 32 | -- @Authorization: Bearer \@ 33 | -- 34 | -- Note that while the token is signed, it is not encrypted. Therefore do not 35 | -- keep in it any information you would not like the client to know. 36 | -- 37 | -- JWTs are described in IETF's 38 | data JWT 39 | 40 | -- | A cookie. The content cookie itself is a JWT. Another cookie is also used, 41 | -- the contents of which are expected to be send back to the server in a 42 | -- header, for XSRF protection. 43 | data Cookie 44 | 45 | 46 | -- We could use 'servant''s BasicAuth, but then we don't get control over the 47 | -- documentation, and we'd have to polykind everything. (Also, we don't 48 | -- currently depend on servant!) 49 | -- 50 | -- | Basic Auth. 51 | data BasicAuth 52 | 53 | -- | Login via a form. 54 | data FormLogin form 55 | -------------------------------------------------------------------------------- /servant-auth/src/Servant/Auth/JWT.hs: -------------------------------------------------------------------------------- 1 | module Servant.Auth.JWT where 2 | 3 | import Control.Lens ((^.)) 4 | import qualified Crypto.JWT as Jose 5 | import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, 6 | toJSON) 7 | import qualified Data.HashMap.Strict as HM 8 | import qualified Data.Text as T 9 | 10 | 11 | -- This should probably also be from ClaimSet 12 | -- 13 | -- | How to decode data from a JWT. 14 | -- 15 | -- The default implementation assumes the data is stored in the unregistered 16 | -- @dat@ claim, and uses the @FromJSON@ instance to decode value from there. 17 | class FromJWT a where 18 | decodeJWT :: Jose.ClaimsSet -> Either T.Text a 19 | default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a 20 | decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of 21 | Nothing -> Left "Missing 'dat' claim" 22 | Just v -> case fromJSON v of 23 | Error e -> Left $ T.pack e 24 | Success a -> Right a 25 | 26 | -- | How to encode data from a JWT. 27 | -- 28 | -- The default implementation stores data in the unregistered @dat@ claim, and 29 | -- uses the type's @ToJSON@ instance to encode the data. 30 | class ToJWT a where 31 | encodeJWT :: a -> Jose.ClaimsSet 32 | default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet 33 | encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet -------------------------------------------------------------------------------- /servant-auth/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /stack-lts16.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | packages: 3 | - servant-auth 4 | - servant-auth-server 5 | - servant-auth-client 6 | - servant-auth-docs 7 | - servant-auth-swagger 8 | -------------------------------------------------------------------------------- /stack-lts17.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.5 2 | packages: 3 | - servant-auth 4 | - servant-auth-server 5 | - servant-auth-client 6 | - servant-auth-docs 7 | - servant-auth-swagger 8 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2021-06-01 2 | packages: 3 | - servant-auth 4 | - servant-auth-server 5 | - servant-auth-client 6 | - servant-auth-docs 7 | - servant-auth-swagger 8 | --------------------------------------------------------------------------------