Skip to content

Commit bd9e4b1

Browse files
akhesaCaroakhesaCaro
authored
Merge pull request #1471 from akhesaCaro/monorepo_servant_auth
repatriation of servant-auth in the main servant repo
2 parents 26b01f0 + e05826a commit bd9e4b1

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

56 files changed

+3306
-0
lines changed

‎cabal.project

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,11 @@
11
packages:
22
servant/
3+
servant-auth/servant-auth
4+
servant-auth/servant-auth-client
5+
servant-auth/servant-auth-docs
6+
servant-auth/servant-auth-server
7+
servant-auth/servant-auth-swagger
8+
39
servant-client/
410
servant-client-core/
511
servant-http-streams/

‎servant-auth/README.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
servant-auth-server/README.lhs

‎servant-auth/servant-auth-client/.ghci

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
:set -isrc -itest -idoctest/ghci-wrapper/src

‎servant-auth/servant-auth-client/CHANGELOG.md

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
# Changelog
2+
3+
All notable changes to this project will be documented in this file.
4+
5+
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+
and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+
## [Unreleased]
9+
10+
## [0.4.1.0] - 2020-10-06
11+
12+
- Support generic Bearer token auth
13+
14+
## [0.4.0.0] - 2019-03-08
15+
16+
## Changed
17+
18+
- #145 Support servant-0.16 in tests @domenkozar
19+
- #145 Drop GHC 7.10 support @domenkozar
20+
21+
## [0.3.3.0] - 2018-06-18
22+
23+
### Added
24+
- Support for GHC 8.4 by @phadej
25+
- Support for servant-0.14 by @phadej
26+
- Changelog by @domenkozar

‎servant-auth/servant-auth-client/LICENSE

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
Copyright Julian K. Arni (c) 2015
2+
3+
All rights reserved.
4+
5+
Redistribution and use in source and binary forms, with or without
6+
modification, are permitted provided that the following conditions are met:
7+
8+
* Redistributions of source code must retain the above copyright
9+
notice, this list of conditions and the following disclaimer.
10+
11+
* Redistributions in binary form must reproduce the above
12+
copyright notice, this list of conditions and the following
13+
disclaimer in the documentation and/or other materials provided
14+
with the distribution.
15+
16+
* Neither the name of Julian K. Arni nor the names of other
17+
contributors may be used to endorse or promote products derived
18+
from this software without specific prior written permission.
19+
20+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+

‎servant-auth/servant-auth-client/Setup.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎servant-auth/servant-auth-client/servant-auth-client.cabal

Lines changed: 82 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,82 @@
1+
name: servant-auth-client
2+
version: 0.4.1.0
3+
synopsis: servant-client/servant-auth compatibility
4+
description: This package provides instances that allow generating clients from
5+
<https://hackage.haskell.org/package/servant servant>
6+
APIs that use
7+
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8+
.
9+
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+
category: Web, Servant, Authentication
11+
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+
bug-reports: https://github.com/haskell-servant/servant/issues
13+
author: Julian K. Arni
14+
maintainer: [email protected]
15+
copyright: (c) Julian K. Arni
16+
license: BSD3
17+
license-file: LICENSE
18+
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19+
build-type: Simple
20+
cabal-version: >= 1.10
21+
extra-source-files:
22+
CHANGELOG.md
23+
24+
source-repository head
25+
type: git
26+
location: https://github.com/haskell-servant/servant
27+
28+
library
29+
hs-source-dirs:
30+
src
31+
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32+
ghc-options: -Wall
33+
build-depends:
34+
base >= 4.10 && < 4.16
35+
, bytestring >= 0.10.6.0 && < 0.11
36+
, containers >= 0.5.6.2 && < 0.7
37+
, servant-auth == 0.4.*
38+
, servant >= 0.13 && < 0.19
39+
, servant-client-core >= 0.13 && < 0.19
40+
41+
exposed-modules:
42+
Servant.Auth.Client
43+
Servant.Auth.Client.Internal
44+
default-language: Haskell2010
45+
46+
test-suite spec
47+
type: exitcode-stdio-1.0
48+
main-is: Spec.hs
49+
hs-source-dirs:
50+
test
51+
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
52+
ghc-options: -Wall
53+
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
54+
55+
-- dependencies with bounds inherited from the library stanza
56+
build-depends:
57+
base
58+
, servant-client
59+
, servant-auth
60+
, servant
61+
, servant-auth-client
62+
if impl(ghc >= 9)
63+
buildable: False
64+
65+
-- test dependencies
66+
build-depends:
67+
hspec >= 2.5.5 && < 2.9
68+
, QuickCheck >= 2.11.3 && < 2.15
69+
, aeson >= 1.3.1.1 && < 1.6
70+
, bytestring >= 0.10.6.0 && < 0.11
71+
, http-client >= 0.5.13.1 && < 0.8
72+
, http-types >= 0.12.2 && < 0.13
73+
, servant-auth-server >= 0.4.2.0 && < 0.5
74+
, servant-server >= 0.13 && < 0.19
75+
, time >= 1.5.0.1 && < 1.13
76+
, transformers >= 0.4.2.0 && < 0.6
77+
, wai >= 3.2.1.2 && < 3.3
78+
, warp >= 3.2.25 && < 3.4
79+
, jose >= 0.7.0.0 && < 0.9
80+
other-modules:
81+
Servant.Auth.ClientSpec
82+
default-language: Haskell2010

‎servant-auth/servant-auth-client/src/Servant/Auth/Client.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module Servant.Auth.Client (Token(..), Bearer) where
2+
3+
import Servant.Auth.Client.Internal (Bearer, Token(..))

‎servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs

Lines changed: 64 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,64 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE UndecidableInstances #-}
4+
{-# OPTIONS_GHC -fno-warn-orphans #-}
5+
#if __GLASGOW_HASKELL__ == 800
6+
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
7+
#endif
8+
module Servant.Auth.Client.Internal where
9+
10+
import qualified Data.ByteString as BS
11+
import Data.Monoid
12+
import Data.Proxy (Proxy (..))
13+
import Data.String (IsString)
14+
import GHC.Exts (Constraint)
15+
import GHC.Generics (Generic)
16+
import Servant.API ((:>))
17+
import Servant.Auth
18+
19+
import Servant.Client.Core
20+
import Data.Sequence ((<|))
21+
22+
-- | A simple bearer token.
23+
newtype Token = Token { getToken :: BS.ByteString }
24+
deriving (Eq, Show, Read, Generic, IsString)
25+
26+
type family HasBearer xs :: Constraint where
27+
HasBearer (Bearer ': xs) = ()
28+
HasBearer (JWT ': xs) = ()
29+
HasBearer (x ': xs) = HasBearer xs
30+
HasBearer '[] = BearerAuthNotEnabled
31+
32+
class BearerAuthNotEnabled
33+
34+
-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not
35+
-- trying to send a token to an API that doesn't accept them.
36+
instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where
37+
type Client m (Auth auths a :> api) = Token -> Client m api
38+
39+
clientWithRoute m _ req (Token token)
40+
= clientWithRoute m (Proxy :: Proxy api)
41+
$ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }
42+
where
43+
headerVal = "Bearer " <> token
44+
45+
#if MIN_VERSION_servant_client_core(0,14,0)
46+
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
47+
#endif
48+
49+
50+
-- * Authentication combinators
51+
52+
-- | A Bearer token in the Authorization header:
53+
--
54+
-- @Authorization: Bearer <token>@
55+
--
56+
-- This can be any token recognized by the server, for example,
57+
-- a JSON Web Token (JWT).
58+
--
59+
-- Note that, since the exact way the token is validated is not specified,
60+
-- this combinator can only be used in the client. The server would not know
61+
-- how to validate it, while the client does not care.
62+
-- If you want to implement Bearer authentication in your server, you have to
63+
-- choose a specific combinator, such as 'JWT'.
64+
data Bearer

‎servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs

Lines changed: 161 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,161 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
module Servant.Auth.ClientSpec (spec) where
4+
5+
import Crypto.JOSE (JWK,
6+
KeyMaterialGenParam (OctGenParam),
7+
genJWK)
8+
import Data.Aeson (FromJSON (..), ToJSON (..))
9+
import qualified Data.ByteString.Lazy as BSL
10+
import Data.Time (UTCTime, defaultTimeLocale,
11+
parseTimeOrError)
12+
import GHC.Generics (Generic)
13+
import Network.HTTP.Client (Manager, defaultManagerSettings,
14+
newManager)
15+
import Network.HTTP.Types (status401)
16+
import Network.Wai.Handler.Warp (testWithApplication)
17+
import Servant
18+
import Servant.Client (BaseUrl (..), Scheme (Http),
19+
ClientError (FailureResponse),
20+
#if MIN_VERSION_servant_client(0,16,0)
21+
ResponseF(..),
22+
#elif MIN_VERSION_servant_client(0,13,0)
23+
GenResponse(..),
24+
#elif MIN_VERSION_servant_client(0,12,0)
25+
Response(..),
26+
#endif
27+
client)
28+
import System.IO.Unsafe (unsafePerformIO)
29+
import Test.Hspec
30+
import Test.QuickCheck
31+
32+
#if MIN_VERSION_servant_client(0,13,0)
33+
import Servant.Client (mkClientEnv, runClientM)
34+
#elif MIN_VERSION_servant_client(0,9,0)
35+
import Servant.Client (ClientEnv (..), runClientM)
36+
#else
37+
import Control.Monad.Trans.Except (runExceptT)
38+
#endif
39+
#if !MIN_VERSION_servant_server(0,16,0)
40+
#define ClientError ServantError
41+
#endif
42+
43+
import Servant.Auth.Client
44+
import Servant.Auth.Server
45+
import Servant.Auth.Server.SetCookieOrphan ()
46+
47+
spec :: Spec
48+
spec = describe "The JWT combinator" $ do
49+
hasClientSpec
50+
51+
52+
------------------------------------------------------------------------------
53+
-- * HasClient {{{
54+
55+
hasClientSpec :: Spec
56+
hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do
57+
58+
let mkTok :: User -> Maybe UTCTime -> IO Token
59+
mkTok user mexp = do
60+
Right tok <- makeJWT user jwtCfg mexp
61+
return $ Token $ BSL.toStrict tok
62+
63+
it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do
64+
tok <- mkTok user Nothing
65+
v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
66+
v `shouldBe` Right (length $ name user)
67+
68+
it "succeeds when the token is not expired" $ \port -> property $ \user -> do
69+
tok <- mkTok user (Just future)
70+
v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
71+
v `shouldBe` Right (length $ name user)
72+
73+
it "fails when token is expired" $ \port -> property $ \user -> do
74+
tok <- mkTok user (Just past)
75+
#if MIN_VERSION_servant_client(0,16,0)
76+
Left (FailureResponse _ (Response stat _ _ _))
77+
#elif MIN_VERSION_servant_client(0,12,0)
78+
Left (FailureResponse (Response stat _ _ _))
79+
#elif MIN_VERSION_servant_client(0,11,0)
80+
Left (FailureResponse _ stat _ _)
81+
#else
82+
Left (FailureResponse stat _ _)
83+
#endif
84+
<- getIntClient tok mgr (BaseUrl Http "localhost" port "")
85+
stat `shouldBe` status401
86+
87+
88+
getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)
89+
#if MIN_VERSION_servant(0,13,0)
90+
getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)
91+
#elif MIN_VERSION_servant(0,9,0)
92+
getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)
93+
#else
94+
getIntClient tok m burl = runExceptT $ client api tok m burl
95+
#endif
96+
-- }}}
97+
------------------------------------------------------------------------------
98+
-- * API and Server {{{
99+
100+
type API = Auth '[JWT] User :> Get '[JSON] Int
101+
102+
api :: Proxy API
103+
api = Proxy
104+
105+
theKey :: JWK
106+
theKey = unsafePerformIO . genJWK $ OctGenParam 256
107+
{-# NOINLINE theKey #-}
108+
109+
mgr :: Manager
110+
mgr = unsafePerformIO $ newManager defaultManagerSettings
111+
{-# NOINLINE mgr #-}
112+
113+
app :: Application
114+
app = serveWithContext api ctx server
115+
where
116+
ctx = cookieCfg :. jwtCfg :. EmptyContext
117+
118+
jwtCfg :: JWTSettings
119+
jwtCfg = defaultJWTSettings theKey
120+
121+
cookieCfg :: CookieSettings
122+
cookieCfg = defaultCookieSettings
123+
124+
125+
server :: Server API
126+
server = getInt
127+
where
128+
getInt :: AuthResult User -> Handler Int
129+
getInt (Authenticated u) = return . length $ name u
130+
getInt _ = throwAll err401
131+
132+
133+
-- }}}
134+
------------------------------------------------------------------------------
135+
-- * Utils {{{
136+
137+
past :: UTCTime
138+
past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
139+
140+
future :: UTCTime
141+
future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
142+
143+
144+
-- }}}
145+
------------------------------------------------------------------------------
146+
-- * Types {{{
147+
148+
data User = User
149+
{ name :: String
150+
, _id :: String
151+
} deriving (Eq, Show, Read, Generic)
152+
153+
instance FromJWT User
154+
instance ToJWT User
155+
instance FromJSON User
156+
instance ToJSON User
157+
158+
instance Arbitrary User where
159+
arbitrary = User <$> arbitrary <*> arbitrary
160+
161+
-- }}}

0 commit comments

Comments
 (0)