eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

repatriation of servant-auth in the main servant repo

Browse source
This commit is contained in:
akhesacaro 2021-10-26 16:08:30 +02:00
parent 26b01f03f2
commit 119e54a800
61 changed files with 3334 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
cabal.project
View file

@ -1,5 +1,11 @@
packages: packages:
servant/ 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/
servant-client-core/ servant-client-core/
servant-http-streams/ servant-http-streams/

1
servant-auth/README.md Symbolic link
View file

@ -0,0 +1 @@
servant-auth-server/README.lhs

7
servant-auth/RELEASE.md Normal file
View file

@ -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

1
servant-auth/servant-auth-client/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -idoctest/ghci-wrapper/src

26
servant-auth/servant-auth-client/CHANGELOG.md Normal file
View file

@ -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

31
servant-auth/servant-auth-client/LICENSE Normal file
View file

@ -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.

2
servant-auth/servant-auth-client/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

80
servant-auth/servant-auth-client/servant-auth-client.cabal Normal file
View file

@ -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

3
servant-auth/servant-auth-client/src/Servant/Auth/Client.hs Normal file
View file

@ -0,0 +1,3 @@
module Servant.Auth.Client (Token(..), Bearer) where
import Servant.Auth.Client.Internal (Bearer, Token(..))

64
servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs Normal file
View file

@ -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

161
servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs Normal file
View file

@ -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
-- }}}

1
servant-auth/servant-auth-client/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

1
servant-auth/servant-auth-docs/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -idoctest/ghci-wrapper/src

14
servant-auth/servant-auth-docs/CHANGELOG.md Normal file
View file

@ -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

31
servant-auth/servant-auth-docs/LICENSE Normal file
View file

@ -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.

33
servant-auth/servant-auth-docs/Setup.hs Normal file
View file

@ -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

84
servant-auth/servant-auth-docs/servant-auth-docs.cabal Normal file
View file

@ -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

96
servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs Normal file
View file

@ -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

1
servant-auth/servant-auth-docs/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

12
servant-auth/servant-auth-docs/test/doctests.hs Normal file
View file

@ -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

1
servant-auth/servant-auth-server/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -idoctest/ghci-wrapper/src

130
servant-auth/servant-auth-server/CHANGELOG.md Normal file
View file

@ -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

31
servant-auth/servant-auth-server/LICENSE Normal file
View file

@ -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.

293
servant-auth/servant-auth-server/README.lhs Normal file
View file

@ -0,0 +1,293 @@
# servant-auth
[![build status](https://img.shields.io/github/workflow/status/haskell-servant/servant-auth/CI/master?style=flat-square&logo=github&label=build%20status)](https://github.com/haskell-servant/servant-auth/actions?query=workflow%3ACI)
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 | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) |
| servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) |
| servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) |
| servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) |
| servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) |
## 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
~~~

1
servant-auth/servant-auth-server/README.md Symbolic link
View file

@ -0,0 +1 @@
README.lhs

2
servant-auth/servant-auth-server/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

129
servant-auth/servant-auth-server/servant-auth-server.cabal Normal file
View file

@ -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

180
servant-auth/servant-auth-server/src/Servant/Auth/Server.hs Normal file
View file

@ -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

70
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs Normal file
View file

@ -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

94
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs Normal file
View file

@ -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

59
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs Normal file
View file

@ -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

72
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs Normal file
View file

@ -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

127
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs Normal file
View file

@ -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
-- }}}

182
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs Normal file
View file

@ -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" #-}

3
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs Normal file
View file

@ -0,0 +1,3 @@
module Servant.Auth.Server.Internal.FormLogin where

71
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs Normal file
View file

@ -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'

49
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs Normal file
View file

@ -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)

112
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs Normal file
View file

@ -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 = (<>)

3
servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs Normal file
View file

@ -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

600
servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs Normal file
View file

@ -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
}
-- }}}

1
servant-auth/servant-auth-server/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

1
servant-auth/servant-auth-swagger/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -idoctest/ghci-wrapper/src

24
servant-auth/servant-auth-swagger/CHANGELOG.md Normal file
View file

@ -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

31
servant-auth/servant-auth-swagger/LICENSE Normal file
View file

@ -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.

2
servant-auth/servant-auth-swagger/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

70
servant-auth/servant-auth-swagger/servant-auth-swagger.cabal Normal file
View file

@ -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

87
servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs Normal file
View file

@ -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 _ = []

38
servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs Normal file
View file

@ -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

1
servant-auth/servant-auth-swagger/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

6
servant-auth/servant-auth.project Normal file
View file

@ -0,0 +1,6 @@
packages:
servant-auth
servant-auth-client
servant-auth-docs
servant-auth-server
servant-auth-swagger

1
servant-auth/servant-auth/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -idoctest/ghci-wrapper/src

20
servant-auth/servant-auth/CHANGELOG.md Normal file
View file

@ -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

31
servant-auth/servant-auth/LICENSE Normal file
View file

@ -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.

2
servant-auth/servant-auth/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

46
servant-auth/servant-auth/servant-auth.cabal Normal file
View file

@ -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

54
servant-auth/servant-auth/src/Servant/Auth.hs Normal file
View file

@ -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

33
servant-auth/servant-auth/src/Servant/Auth/JWT.hs Normal file
View file

@ -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

1
servant-auth/servant-auth/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

7
servant-auth/stack-lts16.yaml Normal file
View file

@ -0,0 +1,7 @@
resolver: lts-16.31
packages:
- servant-auth
- servant-auth-server
- servant-auth-client
- servant-auth-docs
- servant-auth-swagger

7
servant-auth/stack-lts17.yaml Normal file
View file

@ -0,0 +1,7 @@
resolver: lts-17.5
packages:
- servant-auth
- servant-auth-server
- servant-auth-client
- servant-auth-docs
- servant-auth-swagger

7
servant-auth/stack.yaml Normal file
View file

@ -0,0 +1,7 @@
resolver: nightly-2021-06-01
packages:
- servant-auth
- servant-auth-server
- servant-auth-client
- servant-auth-docs
- servant-auth-swagger