repatriation of servant-auth in the main servant repo
This commit is contained in:
akhesacaro
parent
26b01f03f2
commit
119e54a800
|
|
@ -1,5 +1,11 @@
|
|||
packages:
|
||||
servant/
|
||||
servant-auth/servant-auth
|
||||
servant-auth/servant-auth-client
|
||||
servant-auth/servant-auth-docs
|
||||
servant-auth/servant-auth-server
|
||||
servant-auth/servant-auth-swagger
|
||||
|
||||
servant-client/
|
||||
servant-client-core/
|
||||
servant-http-streams/
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
servant-auth-server/README.lhs
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
- update changelog
|
||||
- bump version in cabal file
|
||||
- stack sdist servant-auth-server
|
||||
- git commit -m "v0.4.0.0"
|
||||
- git tag -s servant-auth-server-0.4.0.0
|
||||
- git push --tags
|
||||
- stack upload servant-auth-server
|
||||
|
|
@ -0,0 +1 @@
|
|||
:set -isrc -itest -idoctest/ghci-wrapper/src
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
# Changelog
|
||||
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
|
||||
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.4.1.0] - 2020-10-06
|
||||
|
||||
- Support generic Bearer token auth
|
||||
|
||||
## [0.4.0.0] - 2019-03-08
|
||||
|
||||
## Changed
|
||||
|
||||
- #145 Support servant-0.16 in tests @domenkozar
|
||||
- #145 Drop GHC 7.10 support @domenkozar
|
||||
|
||||
## [0.3.3.0] - 2018-06-18
|
||||
|
||||
### Added
|
||||
- Support for GHC 8.4 by @phadej
|
||||
- Support for servant-0.14 by @phadej
|
||||
- Changelog by @domenkozar
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
Copyright Julian K. Arni (c) 2015
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Julian K. Arni nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
name: servant-auth-client
|
||||
version: 0.4.1.0
|
||||
synopsis: servant-client/servant-auth compatibility
|
||||
description: This package provides instances that allow generating clients from
|
||||
<https://hackage.haskell.org/package/servant servant>
|
||||
APIs that use
|
||||
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
|
||||
.
|
||||
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant-auth#readme README>.
|
||||
category: Web, Servant, Authentication
|
||||
homepage: http://github.com/haskell-servant/servant-auth#readme
|
||||
bug-reports: https://github.com/haskell-servant/servant-auth/issues
|
||||
author: Julian K. Arni
|
||||
maintainer: jkarni@gmail.com
|
||||
copyright: (c) Julian K. Arni
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/haskell-servant/servant-auth
|
||||
|
||||
library
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.16
|
||||
, bytestring >= 0.10.6.0 && < 0.11
|
||||
, containers >= 0.5.6.2 && < 0.7
|
||||
, servant-auth == 0.4.*
|
||||
, servant >= 0.13 && < 0.19
|
||||
, servant-client-core >= 0.13 && < 0.19
|
||||
|
||||
exposed-modules:
|
||||
Servant.Auth.Client
|
||||
Servant.Auth.Client.Internal
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
base
|
||||
, servant-client
|
||||
, servant-auth
|
||||
, servant
|
||||
, servant-auth-client
|
||||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
, aeson >= 1.3.1.1 && < 1.6
|
||||
, bytestring >= 0.10.6.0 && < 0.11
|
||||
, http-client >= 0.5.13.1 && < 0.8
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
, servant-auth-server >= 0.4.2.0 && < 0.5
|
||||
, servant-server >= 0.13 && < 0.19
|
||||
, time >= 1.5.0.1 && < 1.13
|
||||
, transformers >= 0.4.2.0 && < 0.6
|
||||
, wai >= 3.2.1.2 && < 3.3
|
||||
, warp >= 3.2.25 && < 3.4
|
||||
, jose >= 0.7.0.0 && < 0.9
|
||||
other-modules:
|
||||
Servant.Auth.ClientSpec
|
||||
default-language: Haskell2010
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
module Servant.Auth.Client (Token(..), Bearer) where
|
||||
|
||||
import Servant.Auth.Client.Internal (Bearer, Token(..))
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
#if __GLASGOW_HASKELL__ == 800
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
#endif
|
||||
module Servant.Auth.Client.Internal where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Monoid
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.String (IsString)
|
||||
import GHC.Exts (Constraint)
|
||||
import GHC.Generics (Generic)
|
||||
import Servant.API ((:>))
|
||||
import Servant.Auth
|
||||
|
||||
import Servant.Client.Core
|
||||
import Data.Sequence ((<|))
|
||||
|
||||
-- | A simple bearer token.
|
||||
newtype Token = Token { getToken :: BS.ByteString }
|
||||
deriving (Eq, Show, Read, Generic, IsString)
|
||||
|
||||
type family HasBearer xs :: Constraint where
|
||||
HasBearer (Bearer ': xs) = ()
|
||||
HasBearer (JWT ': xs) = ()
|
||||
HasBearer (x ': xs) = HasBearer xs
|
||||
HasBearer '[] = BearerAuthNotEnabled
|
||||
|
||||
class BearerAuthNotEnabled
|
||||
|
||||
-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not
|
||||
-- trying to send a token to an API that doesn't accept them.
|
||||
instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where
|
||||
type Client m (Auth auths a :> api) = Token -> Client m api
|
||||
|
||||
clientWithRoute m _ req (Token token)
|
||||
= clientWithRoute m (Proxy :: Proxy api)
|
||||
$ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }
|
||||
where
|
||||
headerVal = "Bearer " <> token
|
||||
|
||||
#if MIN_VERSION_servant_client_core(0,14,0)
|
||||
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
|
||||
#endif
|
||||
|
||||
|
||||
-- * Authentication combinators
|
||||
|
||||
-- | A Bearer token in the Authorization header:
|
||||
--
|
||||
-- @Authorization: Bearer <token>@
|
||||
--
|
||||
-- This can be any token recognized by the server, for example,
|
||||
-- a JSON Web Token (JWT).
|
||||
--
|
||||
-- Note that, since the exact way the token is validated is not specified,
|
||||
-- this combinator can only be used in the client. The server would not know
|
||||
-- how to validate it, while the client does not care.
|
||||
-- If you want to implement Bearer authentication in your server, you have to
|
||||
-- choose a specific combinator, such as 'JWT'.
|
||||
data Bearer
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
module Servant.Auth.ClientSpec (spec) where
|
||||
|
||||
import Crypto.JOSE (JWK,
|
||||
KeyMaterialGenParam (OctGenParam),
|
||||
genJWK)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Time (UTCTime, defaultTimeLocale,
|
||||
parseTimeOrError)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (Manager, defaultManagerSettings,
|
||||
newManager)
|
||||
import Network.HTTP.Types (status401)
|
||||
import Network.Wai.Handler.Warp (testWithApplication)
|
||||
import Servant
|
||||
import Servant.Client (BaseUrl (..), Scheme (Http),
|
||||
ClientError (FailureResponse),
|
||||
#if MIN_VERSION_servant_client(0,16,0)
|
||||
ResponseF(..),
|
||||
#elif MIN_VERSION_servant_client(0,13,0)
|
||||
GenResponse(..),
|
||||
#elif MIN_VERSION_servant_client(0,12,0)
|
||||
Response(..),
|
||||
#endif
|
||||
client)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
#if MIN_VERSION_servant_client(0,13,0)
|
||||
import Servant.Client (mkClientEnv, runClientM)
|
||||
#elif MIN_VERSION_servant_client(0,9,0)
|
||||
import Servant.Client (ClientEnv (..), runClientM)
|
||||
#else
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
#endif
|
||||
#if !MIN_VERSION_servant_server(0,16,0)
|
||||
#define ClientError ServantError
|
||||
#endif
|
||||
|
||||
import Servant.Auth.Client
|
||||
import Servant.Auth.Server
|
||||
import Servant.Auth.Server.SetCookieOrphan ()
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "The JWT combinator" $ do
|
||||
hasClientSpec
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * HasClient {{{
|
||||
|
||||
hasClientSpec :: Spec
|
||||
hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do
|
||||
|
||||
let mkTok :: User -> Maybe UTCTime -> IO Token
|
||||
mkTok user mexp = do
|
||||
Right tok <- makeJWT user jwtCfg mexp
|
||||
return $ Token $ BSL.toStrict tok
|
||||
|
||||
it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do
|
||||
tok <- mkTok user Nothing
|
||||
v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
|
||||
v `shouldBe` Right (length $ name user)
|
||||
|
||||
it "succeeds when the token is not expired" $ \port -> property $ \user -> do
|
||||
tok <- mkTok user (Just future)
|
||||
v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
|
||||
v `shouldBe` Right (length $ name user)
|
||||
|
||||
it "fails when token is expired" $ \port -> property $ \user -> do
|
||||
tok <- mkTok user (Just past)
|
||||
#if MIN_VERSION_servant_client(0,16,0)
|
||||
Left (FailureResponse _ (Response stat _ _ _))
|
||||
#elif MIN_VERSION_servant_client(0,12,0)
|
||||
Left (FailureResponse (Response stat _ _ _))
|
||||
#elif MIN_VERSION_servant_client(0,11,0)
|
||||
Left (FailureResponse _ stat _ _)
|
||||
#else
|
||||
Left (FailureResponse stat _ _)
|
||||
#endif
|
||||
<- getIntClient tok mgr (BaseUrl Http "localhost" port "")
|
||||
stat `shouldBe` status401
|
||||
|
||||
|
||||
getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)
|
||||
#if MIN_VERSION_servant(0,13,0)
|
||||
getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)
|
||||
#elif MIN_VERSION_servant(0,9,0)
|
||||
getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)
|
||||
#else
|
||||
getIntClient tok m burl = runExceptT $ client api tok m burl
|
||||
#endif
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * API and Server {{{
|
||||
|
||||
type API = Auth '[JWT] User :> Get '[JSON] Int
|
||||
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
theKey :: JWK
|
||||
theKey = unsafePerformIO . genJWK $ OctGenParam 256
|
||||
{-# NOINLINE theKey #-}
|
||||
|
||||
mgr :: Manager
|
||||
mgr = unsafePerformIO $ newManager defaultManagerSettings
|
||||
{-# NOINLINE mgr #-}
|
||||
|
||||
app :: Application
|
||||
app = serveWithContext api ctx server
|
||||
where
|
||||
ctx = cookieCfg :. jwtCfg :. EmptyContext
|
||||
|
||||
jwtCfg :: JWTSettings
|
||||
jwtCfg = defaultJWTSettings theKey
|
||||
|
||||
cookieCfg :: CookieSettings
|
||||
cookieCfg = defaultCookieSettings
|
||||
|
||||
|
||||
server :: Server API
|
||||
server = getInt
|
||||
where
|
||||
getInt :: AuthResult User -> Handler Int
|
||||
getInt (Authenticated u) = return . length $ name u
|
||||
getInt _ = throwAll err401
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Utils {{{
|
||||
|
||||
past :: UTCTime
|
||||
past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
|
||||
|
||||
future :: UTCTime
|
||||
future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Types {{{
|
||||
|
||||
data User = User
|
||||
{ name :: String
|
||||
, _id :: String
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance FromJWT User
|
||||
instance ToJWT User
|
||||
instance FromJSON User
|
||||
instance ToJSON User
|
||||
|
||||
instance Arbitrary User where
|
||||
arbitrary = User <$> arbitrary <*> arbitrary
|
||||
|
||||
-- }}}
|
||||
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -0,0 +1 @@
|
|||
:set -isrc -itest -idoctest/ghci-wrapper/src
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
# Changelog
|
||||
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
|
||||
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.2.10.0] - 2018-06-18
|
||||
|
||||
### Added
|
||||
- Support for GHC 8.4 by @phadej
|
||||
- Changelog by @domenkozar
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
Copyright Julian K. Arni (c) 2015
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Julian K. Arni nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Main (main) where
|
||||
|
||||
#ifndef MIN_VERSION_cabal_doctest
|
||||
#define MIN_VERSION_cabal_doctest(x,y,z) 0
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_cabal_doctest(1,0,0)
|
||||
|
||||
import Distribution.Extra.Doctest ( defaultMainWithDoctests )
|
||||
main :: IO ()
|
||||
main = defaultMainWithDoctests "doctests"
|
||||
|
||||
#else
|
||||
|
||||
#ifdef MIN_VERSION_Cabal
|
||||
-- If the macro is defined, we have new cabal-install,
|
||||
-- but for some reason we don't have cabal-doctest in package-db
|
||||
--
|
||||
-- Probably we are running cabal sdist, when otherwise using new-build
|
||||
-- workflow
|
||||
#warning You are configuring this package without cabal-doctest installed. \
|
||||
The doctests test-suite will not work as a result. \
|
||||
To fix this, install cabal-doctest before configuring.
|
||||
#endif
|
||||
|
||||
import Distribution.Simple
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
name: servant-auth-docs
|
||||
version: 0.2.10.0
|
||||
synopsis: servant-docs/servant-auth compatibility
|
||||
description: This package provides instances that allow generating docs from
|
||||
<https://hackage.haskell.org/package/servant servant>
|
||||
APIs that use
|
||||
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
|
||||
.
|
||||
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant-auth#readme README>.
|
||||
category: Web, Servant, Authentication
|
||||
homepage: http://github.com/haskell-servant/servant-auth#readme
|
||||
bug-reports: https://github.com/haskell-servant/servant-auth/issues
|
||||
author: Julian K. Arni
|
||||
maintainer: jkarni@gmail.com
|
||||
copyright: (c) Julian K. Arni
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
|
||||
build-type: Custom
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
||||
custom-setup
|
||||
setup-depends:
|
||||
base, Cabal, cabal-doctest >=1.0.6 && <1.1
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/haskell-servant/servant-auth
|
||||
|
||||
library
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.16
|
||||
, servant-docs >= 0.11.2 && < 0.12
|
||||
, servant >= 0.13 && < 0.19
|
||||
, servant-auth == 0.4.*
|
||||
, lens >= 4.16.1 && <5.1
|
||||
exposed-modules:
|
||||
Servant.Auth.Docs
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite doctests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: doctests.hs
|
||||
build-depends:
|
||||
base,
|
||||
servant-auth-docs,
|
||||
doctest >= 0.16 && < 0.19,
|
||||
QuickCheck >= 2.11.3 && < 2.15,
|
||||
template-haskell
|
||||
ghc-options: -Wall -threaded
|
||||
hs-source-dirs: test
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
base
|
||||
, text
|
||||
, servant-docs
|
||||
, servant
|
||||
, servant-auth
|
||||
, lens
|
||||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-docs
|
||||
, hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
|
||||
default-language: Haskell2010
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Auth.Docs
|
||||
(
|
||||
-- | The purpose of this package is provide the instance for 'servant-auth'
|
||||
-- combinators needed for 'servant-docs' documentation generation.
|
||||
--
|
||||
-- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int
|
||||
-- >>> putStr $ markdown $ docs (Proxy :: Proxy API)
|
||||
-- ## GET /
|
||||
-- ...
|
||||
-- ... Authentication
|
||||
-- ...
|
||||
-- This part of the API is protected by the following authentication mechanisms:
|
||||
-- ...
|
||||
-- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))
|
||||
-- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)
|
||||
-- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)
|
||||
-- ...
|
||||
-- Clients must supply the following data
|
||||
-- ...
|
||||
-- One of the following:
|
||||
-- ...
|
||||
-- * A JWT Token signed with this server's key
|
||||
-- * Cookies automatically set by browsers, plus a header
|
||||
-- * Cookies automatically set by browsers, plus a header
|
||||
-- ...
|
||||
|
||||
-- * Re-export
|
||||
JWT
|
||||
, BasicAuth
|
||||
, Cookie
|
||||
, Auth
|
||||
) where
|
||||
|
||||
import Control.Lens ((%~), (&), (|>))
|
||||
import Data.List (intercalate)
|
||||
import Data.Monoid
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Servant.API hiding (BasicAuth)
|
||||
import Servant.Auth
|
||||
import Servant.Docs hiding (pretty)
|
||||
import Servant.Docs.Internal (DocAuthentication (..), authInfo)
|
||||
|
||||
instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where
|
||||
docsFor _ (endpoint, action) =
|
||||
docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))
|
||||
where
|
||||
(intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)
|
||||
info = DocAuthentication intro reqData
|
||||
|
||||
|
||||
pretty :: [(String, String)] -> (String, String)
|
||||
pretty [] = error "shouldn't happen"
|
||||
pretty [(i, d)] =
|
||||
( "This part of the API is protected by " <> i
|
||||
, d
|
||||
)
|
||||
pretty rs =
|
||||
( "This part of the API is protected by the following authentication mechanisms:\n\n"
|
||||
++ " * " <> intercalate "\n * " (fst <$> rs)
|
||||
, "\nOne of the following:\n\n"
|
||||
++ " * " <> intercalate "\n * " (snd <$> rs)
|
||||
)
|
||||
|
||||
|
||||
class AllDocs (x :: [*]) where
|
||||
allDocs :: proxy x
|
||||
-- intro, req
|
||||
-> [(String, String)]
|
||||
|
||||
instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where
|
||||
allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)
|
||||
|
||||
instance AllDocs '[] where
|
||||
allDocs _ = []
|
||||
|
||||
class OneDoc a where
|
||||
oneDoc :: proxy a -> (String, String)
|
||||
|
||||
instance OneDoc JWT where
|
||||
oneDoc _ =
|
||||
("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"
|
||||
, "A JWT Token signed with this server's key")
|
||||
|
||||
instance OneDoc Cookie where
|
||||
oneDoc _ =
|
||||
("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"
|
||||
, "Cookies automatically set by browsers, plus a header")
|
||||
|
||||
instance OneDoc BasicAuth where
|
||||
oneDoc _ =
|
||||
( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"
|
||||
, "Cookies automatically set by browsers, plus a header")
|
||||
|
||||
-- $setup
|
||||
-- >>> instance ToSample Int where toSamples _ = singleSample 1729
|
||||
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
module Main where
|
||||
|
||||
import Build_doctests (flags, pkgs, module_sources)
|
||||
import Data.Foldable (traverse_)
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
traverse_ putStrLn args
|
||||
doctest args
|
||||
where
|
||||
args = flags ++ pkgs ++ module_sources
|
||||
|
|
@ -0,0 +1 @@
|
|||
:set -isrc -itest -idoctest/ghci-wrapper/src
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
# Changelog
|
||||
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
|
||||
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.4.6.0] - 2020-10-06
|
||||
|
||||
## Changed
|
||||
|
||||
- expose verifyJWT and use it in two places [@domenkozar]
|
||||
- support GHC 8.10 [@domenkozar]
|
||||
- move ToJWT/FromJWT to servant-auth [@erewok]
|
||||
- #165 fix AnySite with Cookie 3.5.0 [@odr]
|
||||
|
||||
## [0.4.5.1] - 2020-02-06
|
||||
|
||||
## Changed
|
||||
|
||||
- #158 servant 0.17 support [@phadej]
|
||||
|
||||
## [0.4.5.0] - 2019-12-28
|
||||
|
||||
## Changed
|
||||
- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar]
|
||||
- #148 removed unused constaint in HasServer instance for Auth
|
||||
- #154 GHC 8.8 support [@phadej]
|
||||
|
||||
### Added
|
||||
- #141 Support Stream combinator [@domenkozar]
|
||||
- #143 Allow servant-0.16 [@phadej]
|
||||
|
||||
## [0.4.4.0] - 2019-03-02
|
||||
|
||||
### Added
|
||||
- #141 Support Stream combinator [@domenkozar]
|
||||
- #143 Allow servant-0.16 [@phadej]
|
||||
|
||||
## [0.4.3.0] - 2019-01-17
|
||||
|
||||
## Changed
|
||||
- #117 Avoid running auth checks unnecessarily [@sopvop]
|
||||
- #110 Get rid of crypto-api dependency [@domenkozar]
|
||||
- #130 clearSession: improve cross-browser compatibility [@domenkozar]
|
||||
- #136 weed out bytestring-conversion [@stephenirl]
|
||||
|
||||
## [0.4.2.0] - 2018-11-05
|
||||
|
||||
### Added
|
||||
- `Headers hs a` instance for AddSetCookieApi [@domenkozar]
|
||||
- GHC 8.6.x support [@domenkozar]
|
||||
|
||||
## [0.4.1.0] - 2018-10-05
|
||||
|
||||
### Added
|
||||
- #125 Allow setting domain name for a cookie [@domenkozar]
|
||||
|
||||
## Changed
|
||||
- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej]
|
||||
- #114 Export `HasSecurity` typeclass [@rockbmb]
|
||||
|
||||
## [0.4.0.1] - 2018-09-23
|
||||
|
||||
### Security
|
||||
- #123 Session cookie did not apply SameSite attribute [@domenkozar]
|
||||
|
||||
### Added
|
||||
- #112 HasLink instance for Auth combinator [@adetokunbo]
|
||||
- #111 Documentation for using hoistServer [@mschristiansen]
|
||||
- #107 Add utility functions for reading and writing a key to a file [@mschristiansen]
|
||||
|
||||
## [0.4.0.0] - 2018-06-17
|
||||
|
||||
### Added
|
||||
- Support GHC 8.4 by @phadej and @domenkozar
|
||||
- Support for servant-0.14 by @phadej
|
||||
- #96 Support for jose-0.7 by @xaviershay
|
||||
- #92 add `clearSession` for logout by @plredmond and @3noch
|
||||
- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar
|
||||
- #89 Validate JWT against a JWKSet instead of JWK by @sopvop
|
||||
|
||||
### Changed
|
||||
- #92 Rename CSRF to XSRF by @plredmond and @3noch
|
||||
- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional
|
||||
by @plredmond and @3noch
|
||||
- #69 export SameSite by @domenkozar
|
||||
- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar
|
||||
|
||||
### Deprecated
|
||||
- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated
|
||||
by @plredmond and @3noc
|
||||
- #92 Made several changes to the structure of 'CookieSettings' which will require
|
||||
attention by users who have modified the XSRF settings by @plredmond and @3noch
|
||||
|
||||
### Security
|
||||
- #94 Force cookie expiration on serverside by @karshan
|
||||
|
||||
## [0.3.2.0] - 2018-02-21
|
||||
|
||||
### Added
|
||||
- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor
|
||||
- Support for servant-0.14 by @phadej
|
||||
|
||||
### Changed
|
||||
- Disable the readme executable for ghcjs builds by @hamishmack
|
||||
- #84 Make AddSetCookieApi type family open by @qnikst
|
||||
- #79 Make CSRF checks optional for GET requests by @harendra-kumar
|
||||
|
||||
## [0.3.1.0] - 2017-11-08
|
||||
|
||||
### Added
|
||||
- Support for servant-0.12 by @phadej
|
||||
|
||||
## [0.3.0.0] - 2017-11-07
|
||||
|
||||
### Changed
|
||||
- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver
|
||||
|
||||
## [0.2.8.0] - 2017-05-26
|
||||
|
||||
### Added
|
||||
- #45 Support for servant-0.11 by @phadej
|
||||
|
||||
## [0.2.7.0] - 2017-02-11
|
||||
|
||||
### Changed
|
||||
- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
Copyright Julian K. Arni (c) 2015
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Julian K. Arni nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,293 @@
|
|||
# servant-auth
|
||||
|
||||
[](https://github.com/haskell-servant/servant-auth/actions?query=workflow%3ACI)
|
||||
|
||||
These packages provides safe and easy-to-use authentication options for
|
||||
`servant`. The same API can be protected via:
|
||||
- basicauth
|
||||
- cookies
|
||||
- JWT tokens
|
||||
|
||||
|
||||
| Package | Hackage |
|
||||
| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |
|
||||
| servant-auth | [](https://hackage.haskell.org/package/servant-auth) |
|
||||
| servant-auth-server | [](https://hackage.haskell.org/package/servant-auth-server) |
|
||||
| servant-auth-client | [](https://hackage.haskell.org/package/servant-auth-client) |
|
||||
| servant-auth-swagger | [](https://hackage.haskell.org/package/servant-auth-swagger) |
|
||||
| servant-auth-docs | [](https://hackage.haskell.org/package/servant-auth-docs) |
|
||||
|
||||
## How it works
|
||||
|
||||
First some imports:
|
||||
|
||||
~~~ haskell
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import System.Environment (getArgs)
|
||||
import Servant
|
||||
import Servant.Auth.Server
|
||||
import Servant.Auth.Server.SetCookieOrphan ()
|
||||
~~~
|
||||
|
||||
`servant-auth` library introduces a combinator `Auth`:
|
||||
|
||||
~~~ haskell
|
||||
data Auth (auths :: [*]) val
|
||||
~~~
|
||||
|
||||
What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by
|
||||
*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type
|
||||
`AuthResult Something`, where :
|
||||
|
||||
~~~ haskell
|
||||
data AuthResult val
|
||||
= BadPassword
|
||||
| NoSuchUser
|
||||
| Authenticated val
|
||||
| Indefinite
|
||||
~~~
|
||||
|
||||
Your handlers will get a value of type `AuthResult Something`, and can decide
|
||||
what to do with it.
|
||||
|
||||
~~~ haskell
|
||||
|
||||
data User = User { name :: String, email :: String }
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance ToJSON User
|
||||
instance ToJWT User
|
||||
instance FromJSON User
|
||||
instance FromJWT User
|
||||
|
||||
data Login = Login { username :: String, password :: String }
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance ToJSON Login
|
||||
instance FromJSON Login
|
||||
|
||||
type Protected
|
||||
= "name" :> Get '[JSON] String
|
||||
:<|> "email" :> Get '[JSON] String
|
||||
|
||||
|
||||
-- | 'Protected' will be protected by 'auths', which we still have to specify.
|
||||
protected :: Servant.Auth.Server.AuthResult User -> Server Protected
|
||||
-- If we get an "Authenticated v", we can trust the information in v, since
|
||||
-- it was signed by a key we trust.
|
||||
protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)
|
||||
-- Otherwise, we return a 401.
|
||||
protected _ = throwAll err401
|
||||
|
||||
type Unprotected =
|
||||
"login"
|
||||
:> ReqBody '[JSON] Login
|
||||
:> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie]
|
||||
NoContent)
|
||||
:<|> Raw
|
||||
|
||||
unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
|
||||
unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"
|
||||
|
||||
type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected
|
||||
|
||||
server :: CookieSettings -> JWTSettings -> Server (API auths)
|
||||
server cs jwts = protected :<|> unprotected cs jwts
|
||||
|
||||
~~~
|
||||
|
||||
The code is common to all authentications. In order to pick one or more specific
|
||||
authentication methods, all we need to do is provide the expect configuration
|
||||
parameters.
|
||||
|
||||
## API tokens
|
||||
|
||||
The following example illustrates how to protect an API with tokens.
|
||||
|
||||
|
||||
~~~ haskell
|
||||
-- In main, we fork the server, and allow new tokens to be created in the
|
||||
-- command line for the specified user name and email.
|
||||
mainWithJWT :: IO ()
|
||||
mainWithJWT = do
|
||||
-- We generate the key for signing tokens. This would generally be persisted,
|
||||
-- and kept safely
|
||||
myKey <- generateKey
|
||||
-- Adding some configurations. All authentications require CookieSettings to
|
||||
-- be in the context.
|
||||
let jwtCfg = defaultJWTSettings myKey
|
||||
cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
|
||||
--- Here we actually make concrete
|
||||
api = Proxy :: Proxy (API '[JWT])
|
||||
_ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)
|
||||
|
||||
putStrLn "Started server on localhost:7249"
|
||||
putStrLn "Enter name and email separated by a space for a new token"
|
||||
|
||||
forever $ do
|
||||
xs <- words <$> getLine
|
||||
case xs of
|
||||
[name', email'] -> do
|
||||
etoken <- makeJWT (User name' email') jwtCfg Nothing
|
||||
case etoken of
|
||||
Left e -> putStrLn $ "Error generating token:t" ++ show e
|
||||
Right v -> putStrLn $ "New token:\t" ++ show v
|
||||
_ -> putStrLn "Expecting a name and email separated by spaces"
|
||||
|
||||
~~~
|
||||
|
||||
And indeed:
|
||||
|
||||
~~~ bash
|
||||
|
||||
./readme JWT
|
||||
|
||||
Started server on localhost:7249
|
||||
Enter name and email separated by a space for a new token
|
||||
alice alice@gmail.com
|
||||
New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"
|
||||
|
||||
curl localhost:7249/name -v
|
||||
|
||||
* Hostname was NOT found in DNS cache
|
||||
* Trying 127.0.0.1...
|
||||
* Connected to localhost (127.0.0.1) port 7249 (#0)
|
||||
> GET /name HTTP/1.1
|
||||
> User-Agent: curl/7.35.0
|
||||
> Host: localhost:7249
|
||||
> Accept: */*
|
||||
>
|
||||
< HTTP/1.1 401 Unauthorized
|
||||
< Transfer-Encoding: chunked
|
||||
< Date: Wed, 07 Sep 2016 20:17:17 GMT
|
||||
* Server Warp/3.2.7 is not blacklisted
|
||||
< Server: Warp/3.2.7
|
||||
<
|
||||
* Connection #0 to host localhost left intact
|
||||
|
||||
curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \
|
||||
localhost:7249/name -v
|
||||
|
||||
* Hostname was NOT found in DNS cache
|
||||
* Trying 127.0.0.1...
|
||||
* Connected to localhost (127.0.0.1) port 7249 (#0)
|
||||
> GET /name HTTP/1.1
|
||||
> User-Agent: curl/7.35.0
|
||||
> Host: localhost:7249
|
||||
> Accept: */*
|
||||
> Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE
|
||||
>
|
||||
< HTTP/1.1 200 OK
|
||||
< Transfer-Encoding: chunked
|
||||
< Date: Wed, 07 Sep 2016 20:16:11 GMT
|
||||
* Server Warp/3.2.7 is not blacklisted
|
||||
< Server: Warp/3.2.7
|
||||
< Content-Type: application/json
|
||||
< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure
|
||||
< Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure
|
||||
<
|
||||
* Connection #0 to host localhost left intact
|
||||
"alice"%
|
||||
|
||||
|
||||
~~~
|
||||
|
||||
## Cookies
|
||||
|
||||
What if, in addition to API tokens, we want to expose our API to browsers? All
|
||||
we need to do is say so!
|
||||
|
||||
~~~ haskell
|
||||
mainWithCookies :: IO ()
|
||||
mainWithCookies = do
|
||||
-- We *also* need a key to sign the cookies
|
||||
myKey <- generateKey
|
||||
-- Adding some configurations. 'Cookie' requires, in addition to
|
||||
-- CookieSettings, JWTSettings (for signing), so everything is just as before
|
||||
let jwtCfg = defaultJWTSettings myKey
|
||||
cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
|
||||
--- Here is the actual change
|
||||
api = Proxy :: Proxy (API '[Cookie])
|
||||
run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)
|
||||
|
||||
-- Here is the login handler
|
||||
checkCreds :: CookieSettings
|
||||
-> JWTSettings
|
||||
-> Login
|
||||
-> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie]
|
||||
NoContent)
|
||||
checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do
|
||||
-- Usually you would ask a database for the user info. This is just a
|
||||
-- regular servant handler, so you can follow your normal database access
|
||||
-- patterns (including using 'enter').
|
||||
let usr = User "Ali Baba" "ali@email.com"
|
||||
mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr
|
||||
case mApplyCookies of
|
||||
Nothing -> throwError err401
|
||||
Just applyCookies -> return $ applyCookies NoContent
|
||||
checkCreds _ _ _ = throwError err401
|
||||
~~~
|
||||
|
||||
### XSRF and the frontend
|
||||
|
||||
XSRF protection works by requiring that there be a header of the same value as
|
||||
a distinguished cookie that is set by the server on each request. What the
|
||||
cookie and header name are can be configured (see `xsrfCookieName` and
|
||||
`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and
|
||||
"X-XSRF-TOKEN". This means that, if your client is a browser and you're using
|
||||
cookies, Javascript on the client must set the header of each request by
|
||||
reading the cookie. For jQuery, and with the default values, that might be:
|
||||
|
||||
~~~ javascript
|
||||
|
||||
var token = (function() {
|
||||
r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))
|
||||
if (r) return r[1];
|
||||
})();
|
||||
|
||||
|
||||
$.ajaxPrefilter(function(opts, origOpts, xhr) {
|
||||
xhr.setRequestHeader('X-XSRF-TOKEN', token);
|
||||
}
|
||||
|
||||
~~~
|
||||
|
||||
I *believe* nothing at all needs to be done if you're using Angular's `$http`
|
||||
directive, but I haven't tested this.
|
||||
|
||||
XSRF protection can be disabled just for `GET` requests by setting
|
||||
`xsrfExcludeGet = False`. You might want this if you're relying on the browser
|
||||
to navigate between pages that require cookie authentication.
|
||||
|
||||
XSRF protection can be completely disabled by setting `cookieXsrfSetting =
|
||||
Nothing` in `CookieSettings`. This is not recommended! If your cookie
|
||||
authenticated web application runs any javascript, it's recommended to send the
|
||||
XSRF header. However, if your web application runs no javascript, disabling
|
||||
XSRF entirely may be required.
|
||||
|
||||
# Note on this README
|
||||
|
||||
This README is a literate haskell file. Here is 'main', allowing you to pick
|
||||
between the examples above.
|
||||
|
||||
~~~ haskell
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
let usage = "Usage: readme (JWT|Cookie)"
|
||||
case args of
|
||||
["JWT"] -> mainWithJWT
|
||||
["Cookie"] -> mainWithCookies
|
||||
e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage
|
||||
|
||||
~~~
|
||||
|
|
@ -0,0 +1 @@
|
|||
README.lhs
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -0,0 +1,129 @@
|
|||
name: servant-auth-server
|
||||
version: 0.4.6.0
|
||||
synopsis: servant-server/servant-auth compatibility
|
||||
description: This package provides the required instances for using the @Auth@ combinator
|
||||
in your 'servant' server.
|
||||
.
|
||||
Both cookie- and token- (REST API) based authentication is provided.
|
||||
.
|
||||
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant-auth#readme README>.
|
||||
category: Web, Servant, Authentication
|
||||
homepage: http://github.com/haskell-servant/servant-auth#readme
|
||||
bug-reports: https://github.com/haskell-servant/servant-auth/issues
|
||||
author: Julian K. Arni
|
||||
maintainer: jkarni@gmail.com
|
||||
copyright: (c) Julian K. Arni
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/haskell-servant/servant-auth
|
||||
|
||||
library
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.16
|
||||
, aeson >= 1.3.1.1 && < 1.6
|
||||
, base64-bytestring >= 1.0.0.1 && < 1.2
|
||||
, blaze-builder >= 0.4.1.0 && < 0.5
|
||||
, bytestring >= 0.10.6.0 && < 0.11
|
||||
, case-insensitive >= 1.2.0.11 && < 1.3
|
||||
, cookie >= 0.4.4 && < 0.5
|
||||
, data-default-class >= 0.1.2.0 && < 0.2
|
||||
, entropy >= 0.4.1.3 && < 0.5
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
, jose >= 0.7.0.0 && < 0.9
|
||||
, lens >= 4.16.1 && < 5.1
|
||||
, memory >= 0.14.16 && < 0.17
|
||||
, monad-time >= 0.3.1.0 && < 0.4
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, servant >= 0.13 && < 0.19
|
||||
, servant-auth == 0.4.*
|
||||
, servant-server >= 0.13 && < 0.19
|
||||
, tagged >= 0.8.4 && < 0.9
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
, time >= 1.5.0.1 && < 1.10
|
||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||
, wai >= 3.2.1.2 && < 3.3
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >= 0.18.5 && <0.20
|
||||
exposed-modules:
|
||||
Servant.Auth.Server
|
||||
Servant.Auth.Server.Internal
|
||||
Servant.Auth.Server.Internal.AddSetCookie
|
||||
Servant.Auth.Server.Internal.BasicAuth
|
||||
Servant.Auth.Server.Internal.Class
|
||||
Servant.Auth.Server.Internal.ConfigTypes
|
||||
Servant.Auth.Server.Internal.Cookie
|
||||
Servant.Auth.Server.Internal.FormLogin
|
||||
Servant.Auth.Server.Internal.JWT
|
||||
Servant.Auth.Server.Internal.ThrowAll
|
||||
Servant.Auth.Server.Internal.Types
|
||||
Servant.Auth.Server.SetCookieOrphan
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite readme
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: README.lhs
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
build-depends:
|
||||
base
|
||||
, servant-auth
|
||||
, servant-auth-server
|
||||
, servant-server
|
||||
, aeson
|
||||
, mtl
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
if impl(ghcjs)
|
||||
buildable: False
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
base
|
||||
, aeson
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, jose
|
||||
, lens
|
||||
, mtl
|
||||
, time
|
||||
, http-types
|
||||
, wai
|
||||
, servant
|
||||
, servant-server
|
||||
, transformers
|
||||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-server
|
||||
, hspec >= 2.5.5 && < 2.8
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
, http-client >= 0.5.13.1 && < 0.8
|
||||
, lens-aeson >= 1.0.2 && < 1.2
|
||||
, warp >= 3.2.25 && < 3.4
|
||||
, wreq >= 0.5.2.1 && < 0.6
|
||||
other-modules:
|
||||
Servant.Auth.ServerSpec
|
||||
default-language: Haskell2010
|
||||
|
|
@ -0,0 +1,180 @@
|
|||
module Servant.Auth.Server
|
||||
(
|
||||
-- | This package provides implementations for some common authentication
|
||||
-- methods. Authentication yields a trustworthy (because generated by the
|
||||
-- server) value of an some arbitrary type:
|
||||
--
|
||||
-- > type MyApi = Protected
|
||||
-- >
|
||||
-- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails
|
||||
-- >
|
||||
-- > server :: Server Protected
|
||||
-- > server (Authenticated usr) = ... -- here we know the client really is
|
||||
-- > -- who she claims to be
|
||||
-- > server _ = throwAll err401
|
||||
--
|
||||
-- Additional configuration happens via 'Context'.
|
||||
--
|
||||
-- == Example for Custom Handler
|
||||
-- To use a custom 'Servant.Server.Handler' it is necessary to use
|
||||
-- 'Servant.Server.hoistServerWithContext' instead of
|
||||
-- 'Servant.Server.hoistServer' and specify the 'Context'.
|
||||
--
|
||||
-- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the
|
||||
-- 'Context' to create a specialized function equivalent to
|
||||
-- 'Servant.Server.hoistServer' for an API that includes cookie
|
||||
-- authentication.
|
||||
--
|
||||
-- > hoistServerWithAuth
|
||||
-- > :: HasServer api '[CookieSettings, JWTSettings]
|
||||
-- > => Proxy api
|
||||
-- > -> (forall x. m x -> n x)
|
||||
-- > -> ServerT api m
|
||||
-- > -> ServerT api n
|
||||
-- > hoistServerWithAuth api =
|
||||
-- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings])
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- * Auth
|
||||
-- | Basic types
|
||||
Auth
|
||||
, AuthResult(..)
|
||||
, AuthCheck(..)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- * JWT
|
||||
-- | JSON Web Tokens (JWT) are a compact and secure way of transferring
|
||||
-- information between parties. In this library, they are signed by the
|
||||
-- server (or by some other party posessing the relevant key), and used to
|
||||
-- indicate the bearer's identity or authorization.
|
||||
--
|
||||
-- Arbitrary information can be encoded - just declare instances for the
|
||||
-- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that
|
||||
-- usually you'll be trasmitting this information on each request (and
|
||||
-- response!).
|
||||
--
|
||||
-- Note that, while the tokens are signed, they are not encrypted. Do not put
|
||||
-- any information you do not wish the client to know in them!
|
||||
|
||||
-- ** Combinator
|
||||
-- | Re-exported from 'servant-auth'
|
||||
, JWT
|
||||
|
||||
-- ** Classes
|
||||
, FromJWT(..)
|
||||
, ToJWT(..)
|
||||
|
||||
-- ** Related types
|
||||
, IsMatch(..)
|
||||
|
||||
-- ** Settings
|
||||
, JWTSettings(..)
|
||||
, defaultJWTSettings
|
||||
|
||||
-- ** Create check
|
||||
, jwtAuthCheck
|
||||
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- * Cookie
|
||||
-- | Cookies are also a method of identifying and authenticating a user. They
|
||||
-- are particular common when the client is a browser
|
||||
|
||||
-- ** Combinator
|
||||
-- | Re-exported from 'servant-auth'
|
||||
, Cookie
|
||||
|
||||
-- ** Settings
|
||||
, CookieSettings(..)
|
||||
, XsrfCookieSettings(..)
|
||||
, defaultCookieSettings
|
||||
, defaultXsrfCookieSettings
|
||||
, makeSessionCookie
|
||||
, makeSessionCookieBS
|
||||
, makeXsrfCookie
|
||||
, makeCsrfCookie
|
||||
, makeCookie
|
||||
, makeCookieBS
|
||||
, acceptLogin
|
||||
, clearSession
|
||||
|
||||
|
||||
-- ** Related types
|
||||
, IsSecure(..)
|
||||
, SameSite(..)
|
||||
, AreAuths
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- * BasicAuth
|
||||
-- ** Combinator
|
||||
-- | Re-exported from 'servant-auth'
|
||||
, BasicAuth
|
||||
|
||||
-- ** Classes
|
||||
, FromBasicAuthData(..)
|
||||
|
||||
-- ** Settings
|
||||
, BasicAuthCfg
|
||||
|
||||
-- ** Related types
|
||||
, BasicAuthData(..)
|
||||
, IsPasswordCorrect(..)
|
||||
|
||||
-- ** Authentication request
|
||||
, wwwAuthenticatedErr
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- * Utilies
|
||||
, ThrowAll(throwAll)
|
||||
, generateKey
|
||||
, generateSecret
|
||||
, fromSecret
|
||||
, writeKey
|
||||
, readKey
|
||||
, makeJWT
|
||||
, verifyJWT
|
||||
|
||||
-- ** Re-exports
|
||||
, Default(def)
|
||||
, SetCookie
|
||||
) where
|
||||
|
||||
import Prelude hiding (readFile, writeFile)
|
||||
import Data.ByteString (ByteString, writeFile, readFile)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Servant.Auth
|
||||
import Servant.Auth.JWT
|
||||
import Servant.Auth.Server.Internal ()
|
||||
import Servant.Auth.Server.Internal.BasicAuth
|
||||
import Servant.Auth.Server.Internal.Class
|
||||
import Servant.Auth.Server.Internal.ConfigTypes
|
||||
import Servant.Auth.Server.Internal.Cookie
|
||||
import Servant.Auth.Server.Internal.JWT
|
||||
import Servant.Auth.Server.Internal.ThrowAll
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
|
||||
import Crypto.JOSE as Jose
|
||||
import Servant (BasicAuthData (..))
|
||||
import Web.Cookie (SetCookie)
|
||||
|
||||
-- | Generate a key suitable for use with 'defaultConfig'.
|
||||
generateKey :: IO Jose.JWK
|
||||
generateKey = Jose.genJWK $ Jose.OctGenParam 256
|
||||
|
||||
-- | Generate a bytestring suitable for use with 'fromSecret'.
|
||||
generateSecret :: MonadRandom m => m ByteString
|
||||
generateSecret = Jose.getRandomBytes 256
|
||||
|
||||
-- | Restores a key from a bytestring.
|
||||
fromSecret :: ByteString -> Jose.JWK
|
||||
fromSecret = Jose.fromOctets
|
||||
|
||||
-- | Writes a secret to a file. Can for instance be used from the REPL
|
||||
-- to persist a key to a file, which can then be included with the
|
||||
-- application. Restore the key using 'readKey'.
|
||||
writeKey :: FilePath -> IO ()
|
||||
writeKey fp = writeFile fp =<< generateSecret
|
||||
|
||||
-- | Reads a key from a file.
|
||||
readKey :: FilePath -> IO Jose.JWK
|
||||
readKey fp = fromSecret <$> readFile fp
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Servant.Auth.Server.Internal where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Servant ((:>), Handler, HasServer (..),
|
||||
Proxy (..),
|
||||
HasContextEntry(getContextEntry))
|
||||
import Servant.Auth
|
||||
import Servant.Auth.JWT (ToJWT)
|
||||
|
||||
import Servant.Auth.Server.Internal.AddSetCookie
|
||||
import Servant.Auth.Server.Internal.Class
|
||||
import Servant.Auth.Server.Internal.Cookie
|
||||
import Servant.Auth.Server.Internal.ConfigTypes
|
||||
import Servant.Auth.Server.Internal.JWT
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
|
||||
import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
|
||||
|
||||
instance ( n ~ 'S ('S 'Z)
|
||||
, HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v
|
||||
, HasServer api ctxs -- this constraint is needed to implement hoistServer
|
||||
, AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
|
||||
, ToJWT v
|
||||
, HasContextEntry ctxs CookieSettings
|
||||
, HasContextEntry ctxs JWTSettings
|
||||
) => HasServer (Auth auths v :> api) ctxs where
|
||||
type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m
|
||||
|
||||
#if MIN_VERSION_servant_server(0,12,0)
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
#endif
|
||||
|
||||
route _ context subserver =
|
||||
route (Proxy :: Proxy (AddSetCookiesApi n api))
|
||||
context
|
||||
(fmap go subserver `addAuthCheck` authCheck)
|
||||
|
||||
where
|
||||
authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
|
||||
authCheck = withRequest $ \req -> liftIO $ do
|
||||
authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
|
||||
cookies <- makeCookies authResult
|
||||
return (authResult, cookies)
|
||||
|
||||
jwtSettings :: JWTSettings
|
||||
jwtSettings = getContextEntry context
|
||||
|
||||
cookieSettings :: CookieSettings
|
||||
cookieSettings = getContextEntry context
|
||||
|
||||
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
|
||||
makeCookies authResult = do
|
||||
xsrf <- makeXsrfCookie cookieSettings
|
||||
fmap (Just xsrf `SetCookieCons`) $
|
||||
case authResult of
|
||||
(Authenticated v) -> do
|
||||
ejwt <- makeSessionCookie cookieSettings jwtSettings v
|
||||
case ejwt of
|
||||
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
|
||||
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
|
||||
_ -> return $ Nothing `SetCookieCons` SetCookieNil
|
||||
|
||||
go :: (AuthResult v -> ServerT api Handler)
|
||||
-> (AuthResult v, SetCookieList n)
|
||||
-> ServerT (AddSetCookiesApi n api) Handler
|
||||
go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Servant.Auth.Server.Internal.AddSetCookie where
|
||||
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Tagged (Tagged (..))
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (mapResponseHeaders)
|
||||
import Servant
|
||||
import Web.Cookie
|
||||
|
||||
-- What are we doing here? Well, the idea is to add headers to the response,
|
||||
-- but the headers come from the authentication check. In order to do that, we
|
||||
-- tweak a little the general theme of recursing down the API tree; this time,
|
||||
-- we recurse down a variation of it that adds headers to all the endpoints.
|
||||
-- This involves the usual type-level checks.
|
||||
--
|
||||
-- TODO: If the endpoints already have headers, this will not work as is.
|
||||
|
||||
data Nat = Z | S Nat
|
||||
|
||||
type family AddSetCookiesApi (n :: Nat) a where
|
||||
AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a
|
||||
AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)
|
||||
|
||||
type family AddSetCookieApiVerb a where
|
||||
AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
|
||||
AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
|
||||
|
||||
type family AddSetCookieApi a :: *
|
||||
type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
|
||||
type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
|
||||
type instance AddSetCookieApi (Verb method stat ctyps a)
|
||||
= Verb method stat ctyps (AddSetCookieApiVerb a)
|
||||
type instance AddSetCookieApi Raw = Raw
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
type instance AddSetCookieApi (Stream method stat framing ctyps a)
|
||||
= Stream method stat framing ctyps (AddSetCookieApiVerb a)
|
||||
#endif
|
||||
type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)
|
||||
|
||||
data SetCookieList (n :: Nat) :: * where
|
||||
SetCookieNil :: SetCookieList 'Z
|
||||
SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
|
||||
|
||||
class AddSetCookies (n :: Nat) orig new where
|
||||
addSetCookies :: SetCookieList n -> orig -> new
|
||||
|
||||
instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
|
||||
=> AddSetCookies ('S n) (a -> oldb) (a -> newb) where
|
||||
addSetCookies cookies oldfn = addSetCookies cookies . oldfn
|
||||
|
||||
instance AddSetCookies 'Z orig orig where
|
||||
addSetCookies _ = id
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( Functor m
|
||||
, AddSetCookies n (m old) (m cookied)
|
||||
, AddHeader "Set-Cookie" SetCookie cookied new
|
||||
) => AddSetCookies ('S n) (m old) (m new) where
|
||||
addSetCookies (mCookie `SetCookieCons` rest) oldVal =
|
||||
case mCookie of
|
||||
Nothing -> noHeader <$> addSetCookies rest oldVal
|
||||
Just cookie -> addHeader cookie <$> addSetCookies rest oldVal
|
||||
|
||||
instance {-# OVERLAPS #-}
|
||||
(AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')
|
||||
=> AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
|
||||
addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
|
||||
|
||||
-- | for @servant <0.11@
|
||||
instance
|
||||
AddSetCookies ('S n) Application Application where
|
||||
addSetCookies cookies r request respond
|
||||
= r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
|
||||
|
||||
-- | for @servant >=0.11@
|
||||
instance
|
||||
AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where
|
||||
addSetCookies cookies r = Tagged $ \request respond ->
|
||||
unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
|
||||
|
||||
mkHeaders :: SetCookieList x -> [HTTP.Header]
|
||||
mkHeaders x = ("Set-Cookie",) <$> mkCookies x
|
||||
where
|
||||
mkCookies :: forall y. SetCookieList y -> [BS.ByteString]
|
||||
mkCookies SetCookieNil = []
|
||||
mkCookies (SetCookieCons Nothing rest) = mkCookies rest
|
||||
mkCookies (SetCookieCons (Just y) rest)
|
||||
= toByteString (renderSetCookie y) : mkCookies rest
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.Server.Internal.BasicAuth where
|
||||
|
||||
#if !MIN_VERSION_servant_server(0,16,0)
|
||||
#define ServerError ServantErr
|
||||
#endif
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Servant (BasicAuthData (..),
|
||||
ServerError (..), err401)
|
||||
import Servant.Server.Internal.BasicAuth (decodeBAHdr,
|
||||
mkBAChallengerHdr)
|
||||
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
|
||||
-- | A 'ServerError' that asks the client to authenticate via Basic
|
||||
-- Authentication, should be invoked by an application whenever
|
||||
-- appropriate. The argument is the realm.
|
||||
wwwAuthenticatedErr :: BS.ByteString -> ServerError
|
||||
wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }
|
||||
|
||||
-- | A type holding the configuration for Basic Authentication.
|
||||
-- It is defined as a type family with no arguments, so that
|
||||
-- it can be instantiated to whatever type you need to
|
||||
-- authenticate your users (use @type instance BasicAuthCfg = ...@).
|
||||
--
|
||||
-- Note that the instantiation is application-wide,
|
||||
-- i.e. there can be only one instance.
|
||||
-- As a consequence, it should not be instantiated in a library.
|
||||
--
|
||||
-- Basic Authentication expects an element of type 'BasicAuthCfg'
|
||||
-- to be in the 'Context'; that element is then passed automatically
|
||||
-- to the instance of 'FromBasicAuthData' together with the
|
||||
-- authentication data obtained from the client.
|
||||
--
|
||||
-- If you do not need a configuration for Basic Authentication,
|
||||
-- you can use just @BasicAuthCfg = ()@, and recall to also
|
||||
-- add @()@ to the 'Context'.
|
||||
-- A basic but more interesting example is to take as 'BasicAuthCfg'
|
||||
-- a list of authorised username/password pairs:
|
||||
--
|
||||
-- > deriving instance Eq BasicAuthData
|
||||
-- > type instance BasicAuthCfg = [BasicAuthData]
|
||||
-- > instance FromBasicAuthData User where
|
||||
-- > fromBasicAuthData authData authCfg =
|
||||
-- > if elem authData authCfg then ...
|
||||
type family BasicAuthCfg
|
||||
|
||||
class FromBasicAuthData a where
|
||||
-- | Whether the username exists and the password is correct.
|
||||
-- Note that, rather than passing a 'Pass' to the function, we pass a
|
||||
-- function that checks an 'EncryptedPass'. This is to make sure you don't
|
||||
-- accidentally do something untoward with the password, like store it.
|
||||
fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)
|
||||
|
||||
basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr
|
||||
basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of
|
||||
Nothing -> return Indefinite
|
||||
Just baData -> fromBasicAuthData baData cfg
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Auth.Server.Internal.Class where
|
||||
|
||||
import Servant.Auth
|
||||
import Data.Monoid
|
||||
import Servant hiding (BasicAuth)
|
||||
|
||||
import Servant.Auth.JWT
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
import Servant.Auth.Server.Internal.ConfigTypes
|
||||
import Servant.Auth.Server.Internal.BasicAuth
|
||||
import Servant.Auth.Server.Internal.Cookie
|
||||
import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)
|
||||
|
||||
-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all
|
||||
-- elements of @ctx@ to be the in the Context and whose authentication check
|
||||
-- returns an @AuthCheck v@.
|
||||
class IsAuth a v where
|
||||
type family AuthArgs a :: [*]
|
||||
runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)
|
||||
|
||||
instance FromJWT usr => IsAuth Cookie usr where
|
||||
type AuthArgs Cookie = '[CookieSettings, JWTSettings]
|
||||
runAuth _ _ = cookieAuthCheck
|
||||
|
||||
instance FromJWT usr => IsAuth JWT usr where
|
||||
type AuthArgs JWT = '[JWTSettings]
|
||||
runAuth _ _ = jwtAuthCheck
|
||||
|
||||
instance FromBasicAuthData usr => IsAuth BasicAuth usr where
|
||||
type AuthArgs BasicAuth = '[BasicAuthCfg]
|
||||
runAuth _ _ = basicAuthCheck
|
||||
|
||||
-- * Helper
|
||||
|
||||
class AreAuths (as :: [*]) (ctxs :: [*]) v where
|
||||
runAuths :: proxy as -> Context ctxs -> AuthCheck v
|
||||
|
||||
instance AreAuths '[] ctxs v where
|
||||
runAuths _ _ = mempty
|
||||
|
||||
instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
|
||||
, IsAuth a v
|
||||
, AreAuths as ctxs v
|
||||
, AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
|
||||
) => AreAuths (a ': as) ctxs v where
|
||||
runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs
|
||||
where
|
||||
go = appCtx (Proxy :: Proxy (AuthArgs a))
|
||||
ctxs
|
||||
(runAuth (Proxy :: Proxy a) (Proxy :: Proxy v))
|
||||
|
||||
type family Unapp ls res where
|
||||
Unapp '[] res = res
|
||||
Unapp (arg1 ': rest) res = arg1 -> Unapp rest res
|
||||
|
||||
type family App ls res where
|
||||
App '[] res = res
|
||||
App (arg1 ': rest) (arg1 -> res) = App rest res
|
||||
|
||||
-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the
|
||||
-- values from the Context provided.
|
||||
class AppCtx ctx ls res where
|
||||
appCtx :: proxy ls -> Context ctx -> res -> App ls res
|
||||
|
||||
instance ( HasContextEntry ctxs ctx
|
||||
, AppCtx ctxs rest res
|
||||
) => AppCtx ctxs (ctx ': rest) (ctx -> res) where
|
||||
appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx
|
||||
|
||||
instance AppCtx ctx '[] res where
|
||||
appCtx _ _ r = r
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
module Servant.Auth.Server.Internal.ConfigTypes
|
||||
( module Servant.Auth.Server.Internal.ConfigTypes
|
||||
, Servant.API.IsSecure(..)
|
||||
) where
|
||||
|
||||
import Crypto.JOSE as Jose
|
||||
import Crypto.JWT as Jose
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Default.Class
|
||||
import Data.Time
|
||||
import GHC.Generics (Generic)
|
||||
import Servant.API (IsSecure(..))
|
||||
|
||||
data IsMatch = Matches | DoesNotMatch
|
||||
deriving (Eq, Show, Read, Generic, Ord)
|
||||
|
||||
data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect
|
||||
deriving (Eq, Show, Read, Generic, Ord)
|
||||
|
||||
-- The @SameSite@ attribute of cookies determines whether cookies will be sent
|
||||
-- on cross-origin requests.
|
||||
--
|
||||
-- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>
|
||||
-- for more information.
|
||||
data SameSite = AnySite | SameSiteStrict | SameSiteLax
|
||||
deriving (Eq, Show, Read, Generic, Ord)
|
||||
|
||||
-- | @JWTSettings@ are used to generate cookies, and to verify JWTs.
|
||||
data JWTSettings = JWTSettings
|
||||
{
|
||||
-- | Key used to sign JWT.
|
||||
signingKey :: Jose.JWK
|
||||
-- | Algorithm used to sign JWT.
|
||||
, jwtAlg :: Maybe Jose.Alg
|
||||
-- | Keys used to validate JWT.
|
||||
, validationKeys :: Jose.JWKSet
|
||||
-- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
|
||||
-- intended recipient of the JWT.
|
||||
, audienceMatches :: Jose.StringOrURI -> IsMatch
|
||||
} deriving (Generic)
|
||||
|
||||
-- | A @JWTSettings@ where the audience always matches.
|
||||
defaultJWTSettings :: Jose.JWK -> JWTSettings
|
||||
defaultJWTSettings k = JWTSettings
|
||||
{ signingKey = k
|
||||
, jwtAlg = Nothing
|
||||
, validationKeys = Jose.JWKSet [k]
|
||||
, audienceMatches = const Matches }
|
||||
|
||||
-- | The policies to use when generating cookies.
|
||||
--
|
||||
-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will
|
||||
-- treat the cookie as a *session cookie*. These will be deleted when the
|
||||
-- browser is closed.
|
||||
--
|
||||
-- Note that having the setting @Secure@ may cause testing failures if you are
|
||||
-- not testing over HTTPS.
|
||||
data CookieSettings = CookieSettings
|
||||
{
|
||||
-- | 'Secure' means browsers will only send cookies over HTTPS. Default:
|
||||
-- @Secure@.
|
||||
cookieIsSecure :: !IsSecure
|
||||
-- | How long from now until the cookie expires. Default: @Nothing@.
|
||||
, cookieMaxAge :: !(Maybe DiffTime)
|
||||
-- | At what time the cookie expires. Default: @Nothing@.
|
||||
, cookieExpires :: !(Maybe UTCTime)
|
||||
-- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@.
|
||||
, cookiePath :: !(Maybe BS.ByteString)
|
||||
-- | Domain name, if set cookie also allows subdomains. Default: @Nothing@.
|
||||
, cookieDomain :: !(Maybe BS.ByteString)
|
||||
-- | 'SameSite' settings. Default: @SameSiteLax@.
|
||||
, cookieSameSite :: !SameSite
|
||||
-- | What name to use for the cookie used for the session.
|
||||
, sessionCookieName :: !BS.ByteString
|
||||
-- | The optional settings to use for XSRF protection. Default: @Just def@.
|
||||
, cookieXsrfSetting :: !(Maybe XsrfCookieSettings)
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance Default CookieSettings where
|
||||
def = defaultCookieSettings
|
||||
|
||||
defaultCookieSettings :: CookieSettings
|
||||
defaultCookieSettings = CookieSettings
|
||||
{ cookieIsSecure = Secure
|
||||
, cookieMaxAge = Nothing
|
||||
, cookieExpires = Nothing
|
||||
, cookiePath = Just "/"
|
||||
, cookieDomain = Nothing
|
||||
, cookieSameSite = SameSiteLax
|
||||
, sessionCookieName = "JWT-Cookie"
|
||||
, cookieXsrfSetting = Just def
|
||||
}
|
||||
|
||||
-- | The policies to use when generating and verifying XSRF cookies
|
||||
data XsrfCookieSettings = XsrfCookieSettings
|
||||
{
|
||||
-- | What name to use for the cookie used for XSRF protection.
|
||||
xsrfCookieName :: !BS.ByteString
|
||||
-- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.
|
||||
, xsrfCookiePath :: !(Maybe BS.ByteString)
|
||||
-- | What name to use for the header used for XSRF protection.
|
||||
, xsrfHeaderName :: !BS.ByteString
|
||||
-- | Exclude GET request method from XSRF protection.
|
||||
, xsrfExcludeGet :: !Bool
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance Default XsrfCookieSettings where
|
||||
def = defaultXsrfCookieSettings
|
||||
|
||||
defaultXsrfCookieSettings :: XsrfCookieSettings
|
||||
defaultXsrfCookieSettings = XsrfCookieSettings
|
||||
{ xsrfCookieName = "XSRF-TOKEN"
|
||||
, xsrfCookiePath = Just "/"
|
||||
, xsrfHeaderName = "X-XSRF-TOKEN"
|
||||
, xsrfExcludeGet = False
|
||||
}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Internal {{{
|
||||
|
||||
jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings
|
||||
jwtSettingsToJwtValidationSettings s
|
||||
= defaultJWTValidationSettings (toBool <$> audienceMatches s)
|
||||
where
|
||||
toBool Matches = True
|
||||
toBool DoesNotMatch = False
|
||||
-- }}}
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.Server.Internal.Cookie where
|
||||
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Crypto.JOSE as Jose
|
||||
import qualified Crypto.JWT as Jose
|
||||
import Data.ByteArray (constEq)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as BS64
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Time.Calendar (Day(..))
|
||||
import Data.Time.Clock (UTCTime(..), secondsToDiffTime)
|
||||
import Network.HTTP.Types (methodGet)
|
||||
import Network.HTTP.Types.Header(hCookie)
|
||||
import Network.Wai (Request, requestHeaders, requestMethod)
|
||||
import Servant (AddHeader, addHeader)
|
||||
import System.Entropy (getEntropy)
|
||||
import Web.Cookie
|
||||
|
||||
import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)
|
||||
import Servant.Auth.Server.Internal.ConfigTypes
|
||||
import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
|
||||
|
||||
cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
|
||||
cookieAuthCheck ccfg jwtSettings = do
|
||||
req <- ask
|
||||
jwtCookie <- maybe mempty return $ do
|
||||
cookies' <- lookup hCookie $ requestHeaders req
|
||||
let cookies = parseCookies cookies'
|
||||
-- Apply the XSRF check if enabled.
|
||||
guard $ fromMaybe True $ do
|
||||
xsrfCookieCfg <- xsrfCheckRequired ccfg req
|
||||
return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies
|
||||
-- session cookie *must* be HttpOnly and Secure
|
||||
lookup (sessionCookieName ccfg) cookies
|
||||
verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie
|
||||
case verifiedJWT of
|
||||
Nothing -> mzero
|
||||
Just v -> return v
|
||||
|
||||
xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
|
||||
xsrfCheckRequired cookieSettings req = do
|
||||
xsrfCookieCfg <- cookieXsrfSetting cookieSettings
|
||||
let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet
|
||||
guard $ not disableForGetReq
|
||||
return xsrfCookieCfg
|
||||
|
||||
xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool
|
||||
xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do
|
||||
xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies
|
||||
xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req
|
||||
return $ xsrfCookie `constEq` xsrfHeader
|
||||
|
||||
-- | Makes a cookie to be used for XSRF.
|
||||
makeXsrfCookie :: CookieSettings -> IO SetCookie
|
||||
makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of
|
||||
Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings
|
||||
Nothing -> return $ noXsrfTokenCookie cookieSettings
|
||||
where
|
||||
makeRealCookie xsrfCookieSettings = do
|
||||
xsrfValue <- BS64.encode <$> getEntropy 32
|
||||
return
|
||||
$ applyXsrfCookieSettings xsrfCookieSettings
|
||||
$ applyCookieSettings cookieSettings
|
||||
$ def{ setCookieValue = xsrfValue }
|
||||
|
||||
|
||||
-- | Alias for 'makeXsrfCookie'.
|
||||
makeCsrfCookie :: CookieSettings -> IO SetCookie
|
||||
makeCsrfCookie = makeXsrfCookie
|
||||
{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
|
||||
|
||||
|
||||
-- | Makes a cookie with session information.
|
||||
makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
|
||||
makeSessionCookie cookieSettings jwtSettings v = do
|
||||
ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)
|
||||
case ejwt of
|
||||
Left _ -> return Nothing
|
||||
Right jwt -> return
|
||||
$ Just
|
||||
$ applySessionCookieSettings cookieSettings
|
||||
$ applyCookieSettings cookieSettings
|
||||
$ def{ setCookieValue = BSL.toStrict jwt }
|
||||
|
||||
noXsrfTokenCookie :: CookieSettings -> SetCookie
|
||||
noXsrfTokenCookie cookieSettings =
|
||||
applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }
|
||||
|
||||
applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
|
||||
applyCookieSettings cookieSettings setCookie = setCookie
|
||||
{ setCookieMaxAge = cookieMaxAge cookieSettings
|
||||
, setCookieExpires = cookieExpires cookieSettings
|
||||
, setCookiePath = cookiePath cookieSettings
|
||||
, setCookieDomain = cookieDomain cookieSettings
|
||||
, setCookieSecure = case cookieIsSecure cookieSettings of
|
||||
Secure -> True
|
||||
NotSecure -> False
|
||||
}
|
||||
|
||||
applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
|
||||
applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie
|
||||
{ setCookieName = xsrfCookieName xsrfCookieSettings
|
||||
, setCookiePath = xsrfCookiePath xsrfCookieSettings
|
||||
, setCookieHttpOnly = False
|
||||
}
|
||||
|
||||
applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
|
||||
applySessionCookieSettings cookieSettings setCookie = setCookie
|
||||
{ setCookieName = sessionCookieName cookieSettings
|
||||
, setCookieSameSite = case cookieSameSite cookieSettings of
|
||||
AnySite -> anySite
|
||||
SameSiteStrict -> Just sameSiteStrict
|
||||
SameSiteLax -> Just sameSiteLax
|
||||
, setCookieHttpOnly = True
|
||||
}
|
||||
where
|
||||
#if MIN_VERSION_cookie(0,4,5)
|
||||
anySite = Just sameSiteNone
|
||||
#else
|
||||
anySite = Nothing
|
||||
#endif
|
||||
|
||||
-- | For a JWT-serializable session, returns a function that decorates a
|
||||
-- provided response object with XSRF and session cookies. This should be used
|
||||
-- when a user successfully authenticates with credentials.
|
||||
acceptLogin :: ( ToJWT session
|
||||
, AddHeader "Set-Cookie" SetCookie response withOneCookie
|
||||
, AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
|
||||
=> CookieSettings
|
||||
-> JWTSettings
|
||||
-> session
|
||||
-> IO (Maybe (response -> withTwoCookies))
|
||||
acceptLogin cookieSettings jwtSettings session = do
|
||||
mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session
|
||||
case mSessionCookie of
|
||||
Nothing -> pure Nothing
|
||||
Just sessionCookie -> do
|
||||
xsrfCookie <- makeXsrfCookie cookieSettings
|
||||
return $ Just $ addHeader sessionCookie . addHeader xsrfCookie
|
||||
|
||||
-- | Arbitrary cookie expiry time set back in history after unix time 0
|
||||
expireTime :: UTCTime
|
||||
expireTime = UTCTime (ModifiedJulianDay 50000) 0
|
||||
|
||||
-- | Adds headers to a response that clears all session cookies
|
||||
-- | using max-age and expires cookie attributes.
|
||||
clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie
|
||||
, AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
|
||||
=> CookieSettings
|
||||
-> response
|
||||
-> withTwoCookies
|
||||
clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie
|
||||
where
|
||||
-- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both
|
||||
cookieSettingsExpires = cookieSettings
|
||||
{ cookieExpires = Just expireTime
|
||||
, cookieMaxAge = Just (secondsToDiffTime 0)
|
||||
}
|
||||
clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def
|
||||
clearedXsrfCookie = case cookieXsrfSetting cookieSettings of
|
||||
Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def
|
||||
Nothing -> noXsrfTokenCookie cookieSettingsExpires
|
||||
|
||||
makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
|
||||
makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c
|
||||
|
||||
-- | Alias for 'makeSessionCookie'.
|
||||
makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
|
||||
makeCookie = makeSessionCookie
|
||||
{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}
|
||||
|
||||
-- | Alias for 'makeSessionCookieBS'.
|
||||
makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
|
||||
makeCookieBS = makeSessionCookieBS
|
||||
{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
module Servant.Auth.Server.Internal.FormLogin where
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
module Servant.Auth.Server.Internal.JWT where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Crypto.JOSE as Jose
|
||||
import qualified Crypto.JWT as Jose
|
||||
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
|
||||
toJSON)
|
||||
import Data.ByteArray (constEq)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (UTCTime)
|
||||
import Network.Wai (requestHeaders)
|
||||
|
||||
import Servant.Auth.JWT (FromJWT(..), ToJWT(..))
|
||||
import Servant.Auth.Server.Internal.ConfigTypes
|
||||
import Servant.Auth.Server.Internal.Types
|
||||
|
||||
|
||||
-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you
|
||||
-- are protecting a @Raw@ endpoint.
|
||||
jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr
|
||||
jwtAuthCheck jwtSettings = do
|
||||
req <- ask
|
||||
token <- maybe mempty return $ do
|
||||
authHdr <- lookup "Authorization" $ requestHeaders req
|
||||
let bearer = "Bearer "
|
||||
(mbearer, rest) = BS.splitAt (BS.length bearer) authHdr
|
||||
guard (mbearer `constEq` bearer)
|
||||
return rest
|
||||
verifiedJWT <- liftIO $ verifyJWT jwtSettings token
|
||||
case verifiedJWT of
|
||||
Nothing -> mzero
|
||||
Just v -> return v
|
||||
|
||||
-- | Creates a JWT containing the specified data. The data is stored in the
|
||||
-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the
|
||||
-- token expires.
|
||||
makeJWT :: ToJWT a
|
||||
=> a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
|
||||
makeJWT v cfg expiry = runExceptT $ do
|
||||
bestAlg <- Jose.bestJWSAlg $ signingKey cfg
|
||||
let alg = fromMaybe bestAlg $ jwtAlg cfg
|
||||
ejwt <- Jose.signClaims (signingKey cfg)
|
||||
(Jose.newJWSHeader ((), alg))
|
||||
(addExp $ encodeJWT v)
|
||||
|
||||
return $ Jose.encodeCompact ejwt
|
||||
where
|
||||
addExp claims = case expiry of
|
||||
Nothing -> claims
|
||||
Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e
|
||||
|
||||
|
||||
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
|
||||
verifyJWT jwtCfg input = do
|
||||
verifiedJWT <- liftIO $ runExceptT $ do
|
||||
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
|
||||
Jose.verifyClaims
|
||||
(jwtSettingsToJwtValidationSettings jwtCfg)
|
||||
(validationKeys jwtCfg)
|
||||
unverifiedJWT
|
||||
return $ case verifiedJWT of
|
||||
Left (_ :: Jose.JWTError) -> Nothing
|
||||
Right v -> case decodeJWT v of
|
||||
Left _ -> Nothing
|
||||
Right v' -> Just v'
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Auth.Server.Internal.ThrowAll where
|
||||
|
||||
#if !MIN_VERSION_servant_server(0,16,0)
|
||||
#define ServerError ServantErr
|
||||
#endif
|
||||
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Tagged (Tagged (..))
|
||||
import Servant ((:<|>) (..), ServerError(..))
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
class ThrowAll a where
|
||||
-- | 'throwAll' is a convenience function to throw errors across an entire
|
||||
-- sub-API
|
||||
--
|
||||
--
|
||||
-- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
|
||||
-- > == throwError err400 :<|> throwError err400 :<|> err400
|
||||
throwAll :: ServerError -> a
|
||||
|
||||
instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
|
||||
throwAll e = throwAll e :<|> throwAll e
|
||||
|
||||
-- Really this shouldn't be necessary - ((->) a) should be an instance of
|
||||
-- MonadError, no?
|
||||
instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where
|
||||
throwAll e = const $ throwAll e
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where
|
||||
throwAll = throwError
|
||||
|
||||
-- | for @servant <0.11@
|
||||
instance {-# OVERLAPPING #-} ThrowAll Application where
|
||||
throwAll e _req respond
|
||||
= respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
|
||||
(errHeaders e)
|
||||
(errBody e)
|
||||
|
||||
-- | for @servant >=0.11@
|
||||
instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where
|
||||
throwAll e = Tagged $ \_req respond ->
|
||||
respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
|
||||
(errHeaders e)
|
||||
(errBody e)
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.Server.Internal.Types where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Time
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
import Data.Time (getCurrentTime)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Wai (Request)
|
||||
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
|
||||
-- | The result of an authentication attempt.
|
||||
data AuthResult val
|
||||
= BadPassword
|
||||
| NoSuchUser
|
||||
-- | Authentication succeeded.
|
||||
| Authenticated val
|
||||
-- | If an authentication procedure cannot be carried out - if for example it
|
||||
-- expects a password and username in a header that is not present -
|
||||
-- @Indefinite@ is returned. This indicates that other authentication
|
||||
-- methods should be tried.
|
||||
| Indefinite
|
||||
deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)
|
||||
|
||||
instance Semigroup (AuthResult val) where
|
||||
Indefinite <> y = y
|
||||
x <> _ = x
|
||||
|
||||
instance Monoid (AuthResult val) where
|
||||
mempty = Indefinite
|
||||
mappend = (<>)
|
||||
|
||||
instance Applicative AuthResult where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad AuthResult where
|
||||
return = Authenticated
|
||||
Authenticated v >>= f = f v
|
||||
BadPassword >>= _ = BadPassword
|
||||
NoSuchUser >>= _ = NoSuchUser
|
||||
Indefinite >>= _ = Indefinite
|
||||
|
||||
instance Alternative AuthResult where
|
||||
empty = mzero
|
||||
(<|>) = mplus
|
||||
|
||||
instance MonadPlus AuthResult where
|
||||
mzero = mempty
|
||||
mplus = (<>)
|
||||
|
||||
|
||||
-- | An @AuthCheck@ is the function used to decide the authentication status
|
||||
-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a
|
||||
-- Monoid or Alternative; the semantics of this is that the *first*
|
||||
-- non-'Indefinite' result from left to right is used and the rest are ignored.
|
||||
newtype AuthCheck val = AuthCheck
|
||||
{ runAuthCheck :: Request -> IO (AuthResult val) }
|
||||
deriving (Generic, Functor)
|
||||
|
||||
instance Semigroup (AuthCheck val) where
|
||||
AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do
|
||||
fx <- f x
|
||||
case fx of
|
||||
Indefinite -> g x
|
||||
r -> pure r
|
||||
|
||||
instance Monoid (AuthCheck val) where
|
||||
mempty = AuthCheck $ const $ return mempty
|
||||
mappend = (<>)
|
||||
|
||||
instance Applicative AuthCheck where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad AuthCheck where
|
||||
return = AuthCheck . return . return . return
|
||||
AuthCheck ac >>= f = AuthCheck $ \req -> do
|
||||
aresult <- ac req
|
||||
case aresult of
|
||||
Authenticated usr -> runAuthCheck (f usr) req
|
||||
BadPassword -> return BadPassword
|
||||
NoSuchUser -> return NoSuchUser
|
||||
Indefinite -> return Indefinite
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
fail = Fail.fail
|
||||
#endif
|
||||
|
||||
instance Fail.MonadFail AuthCheck where
|
||||
fail _ = AuthCheck . const $ return Indefinite
|
||||
|
||||
instance MonadReader Request AuthCheck where
|
||||
ask = AuthCheck $ \x -> return (Authenticated x)
|
||||
local f (AuthCheck check) = AuthCheck $ \req -> check (f req)
|
||||
|
||||
instance MonadIO AuthCheck where
|
||||
liftIO action = AuthCheck $ const $ Authenticated <$> action
|
||||
|
||||
instance MonadTime AuthCheck where
|
||||
currentTime = liftIO getCurrentTime
|
||||
|
||||
instance Alternative AuthCheck where
|
||||
empty = mzero
|
||||
(<|>) = mplus
|
||||
|
||||
instance MonadPlus AuthCheck where
|
||||
mzero = mempty
|
||||
mplus = (<>)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
module Servant.Auth.Server.SetCookieOrphan
|
||||
{-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-}
|
||||
() where
|
||||
|
|
@ -0,0 +1,600 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.ServerSpec (spec) where
|
||||
|
||||
#if !MIN_VERSION_servant_server(0,16,0)
|
||||
#define ServerError ServantErr
|
||||
#endif
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Crypto.JOSE (Alg (HS256, None), Error,
|
||||
JWK, JWSHeader,
|
||||
KeyMaterialGenParam (OctGenParam),
|
||||
ToCompact, encodeCompact,
|
||||
genJWK, newJWSHeader)
|
||||
import Crypto.JWT (Audience (..), ClaimsSet,
|
||||
NumericDate (NumericDate),
|
||||
SignedJWT,
|
||||
claimAud, claimNbf,
|
||||
signClaims,
|
||||
emptyClaimsSet,
|
||||
unregisteredClaims)
|
||||
import Data.Aeson (FromJSON, ToJSON, Value,
|
||||
toJSON, encode)
|
||||
import Data.Aeson.Lens (_JSON)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Data.Foldable (find)
|
||||
import Data.Monoid
|
||||
import Data.Time
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (cookie_http_only,
|
||||
cookie_name, cookie_value,
|
||||
cookie_expiry_time,
|
||||
destroyCookieJar)
|
||||
import Network.HTTP.Types (Status, status200,
|
||||
status401)
|
||||
import Network.Wai (responseLBS)
|
||||
import Network.Wai.Handler.Warp (testWithApplication)
|
||||
import Network.Wreq (Options, auth, basicAuth,
|
||||
cookieExpiryTime, cookies,
|
||||
defaults, get, getWith, postWith,
|
||||
header, oauth2Bearer,
|
||||
responseBody,
|
||||
responseCookieJar,
|
||||
responseHeader,
|
||||
responseStatus)
|
||||
import Network.Wreq.Types (Postable(..))
|
||||
import Servant hiding (BasicAuth,
|
||||
IsSecure (..), header)
|
||||
import Servant.Auth.Server
|
||||
import Servant.Auth.Server.Internal.Cookie (expireTime)
|
||||
import Servant.Auth.Server.SetCookieOrphan ()
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
import qualified Servant.Types.SourceT as S
|
||||
#endif
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import qualified Network.HTTP.Client as HCli
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
authSpec
|
||||
cookieAuthSpec
|
||||
jwtAuthSpec
|
||||
throwAllSpec
|
||||
basicAuthSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * Auth {{{
|
||||
|
||||
authSpec :: Spec
|
||||
authSpec
|
||||
= describe "The Auth combinator"
|
||||
$ around (testWithApplication . return $ app jwtAndCookieApi) $ do
|
||||
|
||||
it "returns a 401 if all authentications are Indefinite" $ \port -> do
|
||||
get (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "succeeds if one authentication suceeds" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg Nothing
|
||||
opts <- addJwtToHeader jwt
|
||||
resp <- getWith opts (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
it "fails (403) if one authentication fails" $ const $
|
||||
pendingWith "Authentications don't yet fail, only are Indefinite"
|
||||
|
||||
it "doesn't clobber pre-existing response headers" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg Nothing
|
||||
opts <- addJwtToHeader jwt
|
||||
resp <- getWith opts (url port ++ "/header")
|
||||
resp ^. responseHeader "Blah" `shouldBe` "1797"
|
||||
resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
|
||||
|
||||
context "Raw" $ do
|
||||
|
||||
it "gets the response body" $ \port -> property $ \(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg Nothing
|
||||
opts <- addJwtToHeader jwt
|
||||
resp <- getWith opts (url port ++ "/raw")
|
||||
resp ^. responseBody `shouldBe` "how are you?"
|
||||
|
||||
it "doesn't clobber pre-existing reponse headers" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg Nothing
|
||||
opts <- addJwtToHeader jwt
|
||||
resp <- getWith opts (url port ++ "/raw")
|
||||
resp ^. responseHeader "hi" `shouldBe` "there"
|
||||
resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
|
||||
|
||||
|
||||
context "Setting cookies" $ do
|
||||
|
||||
it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims $ toJSON user)
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
|
||||
(xsrfField xsrfCookieName cookieCfg <> "=blah")
|
||||
resp <- getWith opts (url port)
|
||||
let (cookieJar:_) = resp ^.. responseCookieJar
|
||||
Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
|
||||
$ destroyCookieJar cookieJar
|
||||
opts2 = defaults
|
||||
& cookies .~ Just cookieJar
|
||||
& header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
|
||||
resp2 <- getWith opts2 (url port)
|
||||
resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims $ toJSON user)
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
|
||||
(xsrfField xsrfCookieName cookieCfg <> "=blah")
|
||||
resp <- getWith opts (url port)
|
||||
let (cookieJar:_) = resp ^.. responseCookieJar
|
||||
Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
|
||||
$ destroyCookieJar cookieJar
|
||||
xxsrf ^. cookieExpiryTime `shouldBe` future
|
||||
|
||||
it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims $ toJSON user)
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
|
||||
(xsrfField xsrfCookieName cookieCfg <> "=blah")
|
||||
resp <- getWith opts (url port)
|
||||
let (cookieJar:_) = resp ^.. responseCookieJar
|
||||
Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)
|
||||
$ destroyCookieJar cookieJar
|
||||
cookie_http_only token `shouldBe` True
|
||||
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Cookie Auth {{{
|
||||
|
||||
cookieAuthSpec :: Spec
|
||||
cookieAuthSpec
|
||||
= describe "The Auth combinator" $ do
|
||||
describe "With XSRF check" $
|
||||
around (testWithApplication . return $ app cookieOnlyApi) $ do
|
||||
|
||||
it "fails if XSRF header and cookie don't match" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
|
||||
(xsrfField xsrfCookieName cookieCfg <> "=blerg")
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "fails with no XSRF header or cookie" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfg jwt
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
|
||||
(xsrfField xsrfCookieName cookieCfg <> "=blah")
|
||||
resp <- getWith opts (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
it "sets and clears the right cookies" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
let optsFromResp resp =
|
||||
let jar = resp ^. responseCookieJar
|
||||
Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
|
||||
in defaults
|
||||
& cookies .~ Just jar -- real cookie jars aren't updated by being replaced
|
||||
& header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
|
||||
|
||||
resp <- postWith defaults (url port ++ "/login") user
|
||||
(resp ^. responseCookieJar) `shouldMatchCookieNames`
|
||||
[ sessionCookieName cookieCfg
|
||||
, xsrfField xsrfCookieName cookieCfg
|
||||
]
|
||||
let loggedInOpts = optsFromResp resp
|
||||
|
||||
resp <- getWith loggedInOpts (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
-- logout
|
||||
resp <- getWith loggedInOpts (url port ++ "/logout")
|
||||
|
||||
-- assert cookies were expired
|
||||
now <- getCurrentTime
|
||||
let assertCookie c = now >= cookie_expiry_time c
|
||||
all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
|
||||
|
||||
let loggedOutOpts = optsFromResp resp
|
||||
getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
describe "With no XSRF check for GET requests" $ let
|
||||
noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }
|
||||
cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }
|
||||
in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
|
||||
|
||||
it "succeeds with no XSRF header or cookie for GET" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
|
||||
resp <- getWith opts (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
it "fails with no XSRF header or cookie for POST" $ \port -> property
|
||||
$ \(user :: User) number -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
|
||||
postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
|
||||
|
||||
describe "With no XSRF check at all" $ let
|
||||
cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }
|
||||
in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
|
||||
|
||||
it "succeeds with no XSRF header or cookie for GET" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfgNoXsrf jwt
|
||||
resp <- getWith opts (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
it "succeeds with no XSRF header or cookie for POST" $ \port -> property
|
||||
$ \(user :: User) number -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfgNoXsrf jwt
|
||||
resp <- postWith opts (url port) $ toJSON (number :: Int)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just number
|
||||
|
||||
it "sets and clears the right cookies" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
let optsFromResp resp = defaults
|
||||
& cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
|
||||
|
||||
resp <- postWith defaults (url port ++ "/login") user
|
||||
(resp ^. responseCookieJar) `shouldMatchCookieNames`
|
||||
[ sessionCookieName cookieCfg
|
||||
, "NO-XSRF-TOKEN"
|
||||
]
|
||||
let loggedInOpts = optsFromResp resp
|
||||
|
||||
resp <- getWith (loggedInOpts) (url port)
|
||||
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
|
||||
|
||||
resp <- getWith loggedInOpts (url port ++ "/logout")
|
||||
(resp ^. responseCookieJar) `shouldMatchCookieNameValues`
|
||||
[ (sessionCookieName cookieCfg, "value")
|
||||
, ("NO-XSRF-TOKEN", "")
|
||||
]
|
||||
|
||||
-- assert cookies were expired
|
||||
now <- getCurrentTime
|
||||
let assertCookie c = now >= cookie_expiry_time c
|
||||
all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
|
||||
|
||||
let loggedOutOpts = optsFromResp resp
|
||||
|
||||
getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * JWT Auth {{{
|
||||
|
||||
jwtAuthSpec :: Spec
|
||||
jwtAuthSpec
|
||||
= describe "The JWT combinator"
|
||||
$ around (testWithApplication . return $ app jwtOnlyApi) $ do
|
||||
|
||||
it "fails if 'aud' does not match predicate" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
|
||||
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "succeeds if 'aud' does match predicate" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
|
||||
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
|
||||
resp <- getWith opts (url port)
|
||||
resp ^. responseStatus `shouldBe` status200
|
||||
|
||||
it "fails if 'nbf' is set to a future date" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims (toJSON user) & claimNbf .~ Just (NumericDate future))
|
||||
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "fails if 'exp' is set to a past date" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg (Just past)
|
||||
opts <- addJwtToHeader jwt
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "succeeds if 'exp' is set to a future date" $ \port -> property $
|
||||
\(user :: User) -> do
|
||||
jwt <- makeJWT user jwtCfg (Just future)
|
||||
opts <- addJwtToHeader jwt
|
||||
resp <- getWith opts (url port)
|
||||
resp ^. responseStatus `shouldBe` status200
|
||||
|
||||
it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), None))
|
||||
(claims $ toJSON user)
|
||||
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "fails if JWT does not use expected algorithm" $ const $
|
||||
pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
|
||||
|
||||
it "fails if data is not valid JSON" $ \port -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
|
||||
opts <- addJwtToHeader (jwt >>= (return .encodeCompact))
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256))
|
||||
(claims $ toJSON user)
|
||||
resp <- case jwt >>= (return . encodeCompact) of
|
||||
Left (e :: Error) -> fail $ show e
|
||||
Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
|
||||
resp ^. responseStatus `shouldBe` status200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Basic Auth {{{
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
basicAuthSpec = describe "The BasicAuth combinator"
|
||||
$ around (testWithApplication . return $ app basicAuthApi) $ do
|
||||
|
||||
it "succeeds with the correct password and username" $ \port -> do
|
||||
resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
|
||||
resp ^. responseStatus `shouldBe` status200
|
||||
|
||||
it "fails with non-existent user" $ \port -> do
|
||||
getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
|
||||
`shouldHTTPErrorWith` status401
|
||||
|
||||
it "fails with incorrect password" $ \port -> do
|
||||
getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
|
||||
`shouldHTTPErrorWith` status401
|
||||
|
||||
it "fails with no auth header" $ \port -> do
|
||||
get (url port) `shouldHTTPErrorWith` status401
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * ThrowAll {{{
|
||||
|
||||
throwAllSpec :: Spec
|
||||
throwAllSpec = describe "throwAll" $ do
|
||||
|
||||
it "works for plain values" $ do
|
||||
let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
|
||||
t = throwAll err401
|
||||
t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
|
||||
|
||||
it "works for function types" $ property $ \i -> do
|
||||
let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
|
||||
t = throwAll err401
|
||||
expected _ = throwError err401 :<|> throwError err401
|
||||
t i `shouldBe` expected i
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * API and Server {{{
|
||||
|
||||
type API auths
|
||||
= Auth auths User :>
|
||||
( Get '[JSON] Int
|
||||
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int
|
||||
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
|
||||
#endif
|
||||
:<|> "raw" :> Raw
|
||||
)
|
||||
:<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie ] NoContent)
|
||||
:<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie ] NoContent)
|
||||
|
||||
jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
|
||||
jwtOnlyApi = Proxy
|
||||
|
||||
cookieOnlyApi :: Proxy (API '[Cookie])
|
||||
cookieOnlyApi = Proxy
|
||||
|
||||
basicAuthApi :: Proxy (API '[BasicAuth])
|
||||
basicAuthApi = Proxy
|
||||
|
||||
jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
|
||||
jwtAndCookieApi = Proxy
|
||||
|
||||
theKey :: JWK
|
||||
theKey = unsafePerformIO . genJWK $ OctGenParam 256
|
||||
{-# NOINLINE theKey #-}
|
||||
|
||||
|
||||
cookieCfg :: CookieSettings
|
||||
cookieCfg = def
|
||||
{ cookieExpires = Just future
|
||||
, cookieIsSecure = NotSecure
|
||||
, sessionCookieName = "RuncibleSpoon"
|
||||
, cookieXsrfSetting = pure $ def
|
||||
{ xsrfCookieName = "TheyDinedOnMince"
|
||||
, xsrfHeaderName = "AndSlicesOfQuince"
|
||||
}
|
||||
}
|
||||
xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
|
||||
xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
|
||||
|
||||
jwtCfg :: JWTSettings
|
||||
jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->
|
||||
if x == "boo" then DoesNotMatch else Matches }
|
||||
|
||||
instance FromBasicAuthData User where
|
||||
fromBasicAuthData (BasicAuthData usr pwd) _
|
||||
= return $ if usr == "ali" && pwd == "Open sesame"
|
||||
then Authenticated $ User "ali" "ali@the-thieves-den.com"
|
||||
else Indefinite
|
||||
|
||||
-- Could be anything, really, but since this is already in the cfg we don't
|
||||
-- have to add it
|
||||
type instance BasicAuthCfg = JWK
|
||||
|
||||
appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
|
||||
=> Proxy (API auths) -> CookieSettings -> Application
|
||||
appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
|
||||
where
|
||||
ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
|
||||
|
||||
-- | Takes a proxy parameter indicating which authentication systems to enable.
|
||||
app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
|
||||
=> Proxy (API auths) -> Application
|
||||
app api = appWithCookie api cookieCfg
|
||||
|
||||
server :: CookieSettings -> Server (API auths)
|
||||
server ccfg =
|
||||
(\authResult -> case authResult of
|
||||
Authenticated usr -> getInt usr
|
||||
:<|> postInt usr
|
||||
:<|> getHeaderInt
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
:<|> return (S.source ["bytestring"])
|
||||
#endif
|
||||
:<|> raw
|
||||
Indefinite -> throwAll err401
|
||||
_ -> throwAll err403
|
||||
)
|
||||
:<|> getLogin
|
||||
:<|> getLogout
|
||||
where
|
||||
getInt :: User -> Handler Int
|
||||
getInt usr = return . length $ name usr
|
||||
|
||||
postInt :: User -> Int -> Handler Int
|
||||
postInt _ = return
|
||||
|
||||
getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
|
||||
getHeaderInt = return $ addHeader 1797 17
|
||||
|
||||
getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie ] NoContent)
|
||||
getLogin user = do
|
||||
maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
|
||||
case maybeApplyCookies of
|
||||
Just applyCookies -> return $ applyCookies NoContent
|
||||
Nothing -> error "cookies failed to apply"
|
||||
|
||||
getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie ] NoContent)
|
||||
getLogout = return $ clearSession ccfg NoContent
|
||||
|
||||
raw :: Server Raw
|
||||
raw =
|
||||
#if MIN_VERSION_servant_server(0,11,0)
|
||||
Tagged $
|
||||
#endif
|
||||
\_req respond ->
|
||||
respond $ responseLBS status200 [("hi", "there")] "how are you?"
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Utils {{{
|
||||
|
||||
past :: UTCTime
|
||||
past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
|
||||
|
||||
future :: UTCTime
|
||||
future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
|
||||
|
||||
addJwtToHeader :: Either Error BSL.ByteString -> IO Options
|
||||
addJwtToHeader jwt = case jwt of
|
||||
Left e -> fail $ show e
|
||||
Right v -> return
|
||||
$ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
|
||||
|
||||
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
|
||||
createJWT k a b = runExceptT $ signClaims k a b
|
||||
|
||||
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
|
||||
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
|
||||
Left e -> fail $ show e
|
||||
Right v -> return
|
||||
$ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
|
||||
|
||||
addCookie :: Options -> BS.ByteString -> Options
|
||||
addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of
|
||||
[h] -> [cookie' <> "; " <> h]
|
||||
[] -> [cookie']
|
||||
_ -> error "expecting single cookie header"
|
||||
|
||||
|
||||
shouldHTTPErrorWith :: IO a -> Status -> Expectation
|
||||
shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
|
||||
#if MIN_VERSION_http_client(0,5,0)
|
||||
HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
|
||||
-> HCli.responseStatus resp == stat
|
||||
#else
|
||||
HCli.StatusCodeException x _ _ -> x == stat
|
||||
#endif
|
||||
_ -> False
|
||||
|
||||
shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
|
||||
shouldMatchCookieNames cj patterns
|
||||
= fmap cookie_name (destroyCookieJar cj)
|
||||
`shouldMatchList` patterns
|
||||
|
||||
shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
|
||||
shouldMatchCookieNameValues cj patterns
|
||||
= fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
|
||||
`shouldMatchList` patterns
|
||||
|
||||
url :: Int -> String
|
||||
url port = "http://localhost:" <> show port
|
||||
|
||||
claims :: Value -> ClaimsSet
|
||||
claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Types {{{
|
||||
|
||||
data User = User
|
||||
{ name :: String
|
||||
, _id :: String
|
||||
} deriving (Eq, Show, Read, Generic)
|
||||
|
||||
instance FromJWT User
|
||||
instance ToJWT User
|
||||
instance FromJSON User
|
||||
instance ToJSON User
|
||||
|
||||
instance Arbitrary User where
|
||||
arbitrary = User <$> arbitrary <*> arbitrary
|
||||
|
||||
instance Postable User where
|
||||
postPayload user request = return $ request
|
||||
{ HCli.requestBody = HCli.RequestBodyLBS $ encode user
|
||||
, HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
|
||||
}
|
||||
|
||||
|
||||
-- }}}
|
||||
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -0,0 +1 @@
|
|||
:set -isrc -itest -idoctest/ghci-wrapper/src
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
# Changelog
|
||||
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
|
||||
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.2.10.1] - 2020-10-06
|
||||
|
||||
### Changed
|
||||
|
||||
- Support GHC 8.10 @domenkozar
|
||||
- Fix build with swagger 2.5.x @domenkozar
|
||||
|
||||
## [0.2.10.0] - 2018-06-18
|
||||
|
||||
### Added
|
||||
|
||||
- Support for GHC 8.4 by @phadej
|
||||
- Changelog by @domenkozar
|
||||
- #93: Add Cookie in SwaggerSpec API by @domenkozar
|
||||
- #42: Add dummy AllHasSecurity Cookie instance by @sordina
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
Copyright Julian K. Arni (c) 2015
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Julian K. Arni nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
name: servant-auth-swagger
|
||||
version: 0.2.10.1
|
||||
synopsis: servant-swagger/servant-auth compatibility
|
||||
description: This package provides instances that allow generating swagger2 schemas from
|
||||
<https://hackage.haskell.org/package/servant servant>
|
||||
APIs that use
|
||||
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
|
||||
.
|
||||
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant-auth#readme README>.
|
||||
category: Web, Servant, Authentication
|
||||
homepage: http://github.com/haskell-servant/servant-auth#readme
|
||||
bug-reports: https://github.com/haskell-servant/servant-auth/issues
|
||||
author: Julian K. Arni
|
||||
maintainer: jkarni@gmail.com
|
||||
copyright: (c) Julian K. Arni
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/haskell-servant/servant-auth
|
||||
|
||||
library
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.16
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
, servant-swagger >= 1.1.5 && < 1.8
|
||||
, swagger2 >= 2.2.2 && < 2.7
|
||||
, servant >= 0.13 && < 0.19
|
||||
, servant-auth == 0.4.*
|
||||
, lens >= 4.16.1 && < 5.1
|
||||
exposed-modules:
|
||||
Servant.Auth.Swagger
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
base
|
||||
, text
|
||||
, servant-swagger
|
||||
, swagger2
|
||||
, servant
|
||||
, servant-auth
|
||||
, lens
|
||||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-swagger
|
||||
, hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
other-modules:
|
||||
Servant.Auth.SwaggerSpec
|
||||
default-language: Haskell2010
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.Swagger
|
||||
(
|
||||
-- | The purpose of this package is provide the instance for 'servant-auth'
|
||||
-- combinators needed for 'servant-swagger' documentation generation.
|
||||
--
|
||||
-- Currently only JWT and BasicAuth are supported.
|
||||
|
||||
-- * Re-export
|
||||
JWT
|
||||
, BasicAuth
|
||||
, Auth
|
||||
|
||||
-- * Needed to define instances of @HasSwagger@
|
||||
, HasSecurity (..)
|
||||
) where
|
||||
|
||||
import Control.Lens ((&), (<>~))
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..),
|
||||
SecurityRequirement (..), SecurityScheme (..),
|
||||
#if MIN_VERSION_swagger2(2,6,0)
|
||||
SecurityDefinitions(..),
|
||||
#endif
|
||||
SecuritySchemeType (..), allOperations, security,
|
||||
securityDefinitions)
|
||||
import GHC.Exts (fromList)
|
||||
import Servant.API hiding (BasicAuth)
|
||||
import Servant.Auth
|
||||
import Servant.Swagger
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where
|
||||
toSwagger _
|
||||
= toSwagger (Proxy :: Proxy api)
|
||||
& securityDefinitions <>~ mkSec (fromList secs)
|
||||
& allOperations.security <>~ secReqs
|
||||
where
|
||||
secs = securities (Proxy :: Proxy xs)
|
||||
secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs]
|
||||
mkSec =
|
||||
#if MIN_VERSION_swagger2(2,6,0)
|
||||
SecurityDefinitions
|
||||
#else
|
||||
id
|
||||
#endif
|
||||
|
||||
|
||||
class HasSecurity x where
|
||||
securityName :: Proxy x -> T.Text
|
||||
securityScheme :: Proxy x -> SecurityScheme
|
||||
|
||||
instance HasSecurity BasicAuth where
|
||||
securityName _ = "BasicAuth"
|
||||
securityScheme _ = SecurityScheme type_ (Just desc)
|
||||
where
|
||||
type_ = SecuritySchemeBasic
|
||||
desc = "Basic access authentication"
|
||||
|
||||
instance HasSecurity JWT where
|
||||
securityName _ = "JwtSecurity"
|
||||
securityScheme _ = SecurityScheme type_ (Just desc)
|
||||
where
|
||||
type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)
|
||||
desc = "JSON Web Token-based API key"
|
||||
|
||||
class AllHasSecurity (x :: [*]) where
|
||||
securities :: Proxy x -> [(T.Text,SecurityScheme)]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where
|
||||
securities _ = (securityName px, securityScheme px) : securities pxs
|
||||
where
|
||||
px :: Proxy x
|
||||
px = Proxy
|
||||
pxs :: Proxy xs
|
||||
pxs = Proxy
|
||||
|
||||
instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where
|
||||
securities _ = securities pxs
|
||||
where
|
||||
pxs :: Proxy xs
|
||||
pxs = Proxy
|
||||
|
||||
instance AllHasSecurity '[] where
|
||||
securities _ = []
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Auth.SwaggerSpec (spec) where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Auth
|
||||
import Servant.Auth.Swagger
|
||||
import Data.Swagger
|
||||
import Servant.Swagger
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "HasSwagger instance" $ do
|
||||
|
||||
let swag = toSwagger (Proxy :: Proxy API)
|
||||
|
||||
it "adds security definitions at the top level" $ do
|
||||
#if MIN_VERSION_swagger2(2,6,0)
|
||||
let (SecurityDefinitions secDefs) = swag ^. securityDefinitions
|
||||
#else
|
||||
let secDefs = swag ^. securityDefinitions
|
||||
#endif
|
||||
length secDefs `shouldSatisfy` (> 0)
|
||||
|
||||
it "adds security at sub-apis" $ do
|
||||
swag ^. security `shouldBe` []
|
||||
show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity"
|
||||
show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity"
|
||||
|
||||
-- * API
|
||||
|
||||
type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI
|
||||
:<|> "insecure" :> InsecureAPI
|
||||
|
||||
type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
|
||||
|
||||
type InsecureAPI = SecureAPI
|
||||
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
packages:
|
||||
servant-auth
|
||||
servant-auth-client
|
||||
servant-auth-docs
|
||||
servant-auth-server
|
||||
servant-auth-swagger
|
||||
|
|
@ -0,0 +1 @@
|
|||
:set -isrc -itest -idoctest/ghci-wrapper/src
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
# Changelog
|
||||
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
|
||||
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [0.4.0.0] - 2020-10-06
|
||||
|
||||
- Support for GHC 8.10 by @domenkozar
|
||||
- Support servant 0.18 by @domenkozar
|
||||
- Move `ToJWT/FromJWT` from servant-auth-server
|
||||
|
||||
## [0.3.2.0] - 2018-06-18
|
||||
|
||||
### Added
|
||||
- Support for GHC 8.4 by @phadej
|
||||
- Changelog by @domenkozar
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
Copyright Julian K. Arni (c) 2015
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Julian K. Arni nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
name: servant-auth
|
||||
version: 0.4.0.0
|
||||
synopsis: Authentication combinators for servant
|
||||
description: This package provides an @Auth@ combinator for 'servant'. This combinator
|
||||
allows using different authentication schemes in a straightforward way,
|
||||
and possibly in conjunction with one another.
|
||||
.
|
||||
'servant-auth' additionally provides concrete authentication schemes, such
|
||||
as Basic Access Authentication, JSON Web Tokens, and Cookies.
|
||||
.
|
||||
For more details on how to use this, see the <http://github.com/haskell-servant/servant-auth#readme README>.
|
||||
category: Web, Servant, Authentication
|
||||
homepage: http://github.com/haskell-servant/servant-auth#readme
|
||||
bug-reports: https://github.com/haskell-servant/servant-auth/issues
|
||||
author: Julian K. Arni
|
||||
maintainer: jkarni@gmail.com
|
||||
copyright: (c) Julian K. Arni
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/haskell-servant/servant-auth
|
||||
|
||||
library
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.16
|
||||
, aeson >= 1.3.1.1 && < 1.6
|
||||
, jose >= 0.7.0.0 && < 0.9
|
||||
, lens >= 4.16.1 && < 5.1
|
||||
, servant >= 0.15 && < 0.19
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||
exposed-modules:
|
||||
Servant.Auth
|
||||
Servant.Auth.JWT
|
||||
default-language: Haskell2010
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Auth where
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Servant.API ((:>))
|
||||
import Servant.Links (HasLink (..))
|
||||
|
||||
-- * Authentication
|
||||
|
||||
-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by
|
||||
-- @auth1@ or @auth2@
|
||||
data Auth (auths :: [*]) val
|
||||
|
||||
-- | A @HasLink@ instance for @Auth@
|
||||
instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
|
||||
#if MIN_VERSION_servant(0,14,0)
|
||||
type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
#else
|
||||
type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
#endif
|
||||
|
||||
-- ** Combinators
|
||||
|
||||
-- | A JSON Web Token (JWT) in the the Authorization header:
|
||||
--
|
||||
-- @Authorization: Bearer \<token\>@
|
||||
--
|
||||
-- Note that while the token is signed, it is not encrypted. Therefore do not
|
||||
-- keep in it any information you would not like the client to know.
|
||||
--
|
||||
-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>
|
||||
data JWT
|
||||
|
||||
-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,
|
||||
-- the contents of which are expected to be send back to the server in a
|
||||
-- header, for XSRF protection.
|
||||
data Cookie
|
||||
|
||||
|
||||
-- We could use 'servant''s BasicAuth, but then we don't get control over the
|
||||
-- documentation, and we'd have to polykind everything. (Also, we don't
|
||||
-- currently depend on servant!)
|
||||
--
|
||||
-- | Basic Auth.
|
||||
data BasicAuth
|
||||
|
||||
-- | Login via a form.
|
||||
data FormLogin form
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
module Servant.Auth.JWT where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import qualified Crypto.JWT as Jose
|
||||
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
|
||||
toJSON)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
-- This should probably also be from ClaimSet
|
||||
--
|
||||
-- | How to decode data from a JWT.
|
||||
--
|
||||
-- The default implementation assumes the data is stored in the unregistered
|
||||
-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there.
|
||||
class FromJWT a where
|
||||
decodeJWT :: Jose.ClaimsSet -> Either T.Text a
|
||||
default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a
|
||||
decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of
|
||||
Nothing -> Left "Missing 'dat' claim"
|
||||
Just v -> case fromJSON v of
|
||||
Error e -> Left $ T.pack e
|
||||
Success a -> Right a
|
||||
|
||||
-- | How to encode data from a JWT.
|
||||
--
|
||||
-- The default implementation stores data in the unregistered @dat@ claim, and
|
||||
-- uses the type's @ToJSON@ instance to encode the data.
|
||||
class ToJWT a where
|
||||
encodeJWT :: a -> Jose.ClaimsSet
|
||||
default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet
|
||||
encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet
|
||||
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
resolver: lts-16.31
|
||||
packages:
|
||||
- servant-auth
|
||||
- servant-auth-server
|
||||
- servant-auth-client
|
||||
- servant-auth-docs
|
||||
- servant-auth-swagger
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
resolver: lts-17.5
|
||||
packages:
|
||||
- servant-auth
|
||||
- servant-auth-server
|
||||
- servant-auth-client
|
||||
- servant-auth-docs
|
||||
- servant-auth-swagger
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
resolver: nightly-2021-06-01
|
||||
packages:
|
||||
- servant-auth
|
||||
- servant-auth-server
|
||||
- servant-auth-client
|
||||
- servant-auth-docs
|
||||
- servant-auth-swagger
|
||||
Loading…
Reference in New Issue