Skip to content

Commit aee1917

Browse files
gdeestgoogleson78Gaël Deest
authored
Support UVerb in servant-auth-server (#1571)
Co-authored-by: Georgi Lyubenov <[email protected]> Co-authored-by: Gaël Deest <[email protected]>
1 parent a2e0033 commit aee1917

File tree

7 files changed

+85
-13
lines changed

7 files changed

+85
-13
lines changed

‎changelog.d/1571

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
synopsis: Support UVerb in servant-auth-server
2+
prs: #1571
3+
issues: #1570
4+
description: {
5+
UVerb endpoints are now supported by servant-auth-server and can be used under the
6+
Auth combinator when writing servers. It is still unsupported by
7+
servant-auth-client.
8+
}

‎servant-auth/servant-auth-server/servant-auth-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -129,6 +129,7 @@ test-suite spec
129129
, lens-aeson >= 1.0.2 && < 1.3
130130
, warp >= 3.2.25 && < 3.4
131131
, wreq >= 0.5.2.1 && < 0.6
132+
, text >= 1.2.3.0 && < 2.1
132133
other-modules:
133134
Servant.Auth.ServerSpec
134135
default-language: Haskell2010

‎servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs

Lines changed: 6 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)
5454

5555
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
5656
makeCookies authResult = do
57-
xsrf <- makeXsrfCookie cookieSettings
58-
fmap (Just xsrf `SetCookieCons`) $
59-
case authResult of
60-
(Authenticated v) -> do
61-
ejwt <- makeSessionCookie cookieSettings jwtSettings v
62-
case ejwt of
63-
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
64-
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
65-
_ -> return $ Nothing `SetCookieCons` SetCookieNil
57+
case authResult of
58+
(Authenticated v) -> do
59+
ejwt <- makeSessionCookie cookieSettings jwtSettings v
60+
xsrf <- makeXsrfCookie cookieSettings
61+
return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
62+
_ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
6663

6764
go :: (AuthResult v -> ServerT api Handler)
6865
-> (AuthResult v, SetCookieList n)

‎servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))
1111
import qualified Network.HTTP.Types as HTTP
1212
import Network.Wai (mapResponseHeaders)
1313
import Servant
14+
import Servant.API.UVerb.Union
1415
import Servant.API.Generic
1516
import Servant.Server.Generic
1617
import Web.Cookie
@@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where
3334
AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
3435
AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
3536

37+
#if MIN_VERSION_servant_server(0,18,1)
38+
type family MapAddSetCookieApiVerb (as :: [*]) where
39+
MapAddSetCookieApiVerb '[] = '[]
40+
MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
41+
#endif
42+
3643
type family AddSetCookieApi a :: *
3744
type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
3845
type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
46+
#if MIN_VERSION_servant_server(0,19,0)
3947
type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
48+
#endif
4049
type instance AddSetCookieApi (Verb method stat ctyps a)
4150
= Verb method stat ctyps (AddSetCookieApiVerb a)
51+
#if MIN_VERSION_servant_server(0,18,1)
52+
type instance AddSetCookieApi (UVerb method ctyps as)
53+
= UVerb method ctyps (MapAddSetCookieApiVerb as)
54+
#endif
4255
type instance AddSetCookieApi Raw = Raw
4356
#if MIN_VERSION_servant_server(0,15,0)
4457
type instance AddSetCookieApi (Stream method stat framing ctyps a)
@@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
5770
=> AddSetCookies ('S n) (a -> oldb) (a -> newb) where
5871
addSetCookies cookies oldfn = addSetCookies cookies . oldfn
5972

60-
instance AddSetCookies 'Z orig orig where
73+
instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
6174
addSetCookies _ = id
6275

6376
instance {-# OVERLAPPABLE #-}

‎servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs

Lines changed: 31 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE TypeApplications #-}
23
module Servant.Auth.ServerSpec (spec) where
34

45
#if !MIN_VERSION_servant_server(0,16,0)
@@ -24,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,
2425
import Data.Aeson.Lens (_JSON)
2526
import qualified Data.ByteString as BS
2627
import qualified Data.ByteString.Lazy as BSL
28+
import Data.Text (Text, pack)
2729
import Data.CaseInsensitive (mk)
2830
import Data.Foldable (find)
2931
import Data.Monoid
@@ -39,6 +41,7 @@ import Network.HTTP.Types (Status, status200,
3941
import Network.Wai (responseLBS)
4042
import Network.Wai.Handler.Warp (testWithApplication)
4143
import Network.Wreq (Options, auth, basicAuth,
44+
checkResponse,
4245
cookieExpiryTime, cookies,
4346
defaults, get, getWith, postWith,
4447
header, oauth2Bearer,
@@ -182,8 +185,21 @@ cookieAuthSpec
182185
it "fails with no XSRF header or cookie" $ \port -> property
183186
$ \(user :: User) -> do
184187
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
185-
opts <- addJwtToCookie cookieCfg jwt
186-
getWith opts (url port) `shouldHTTPErrorWith` status401
188+
opts' <- addJwtToCookie cookieCfg jwt
189+
let opts = opts' & checkResponse .~ Just mempty
190+
resp <- getWith opts (url port)
191+
resp ^. responseStatus `shouldBe` status401
192+
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
193+
194+
-- Validating that the XSRF cookie isn't added for UVerb routes either.
195+
-- These routes can return a 401 response directly without using throwError / throwAll,
196+
-- which revealed a bug:
197+
--
198+
-- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
199+
resp <- getWith opts (url port ++ "/uverb")
200+
resp ^. responseStatus `shouldBe` status401
201+
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
202+
187203

188204
it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
189205
$ \(user :: User) -> do
@@ -405,13 +421,14 @@ type API auths
405421
= Auth auths User :>
406422
( Get '[JSON] Int
407423
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int
408-
:<|> NamedRoutes DummyRoutes
424+
:<|> "named" :> NamedRoutes DummyRoutes
409425
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
410426
#if MIN_VERSION_servant_server(0,15,0)
411427
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
412428
#endif
413429
:<|> "raw" :> Raw
414430
)
431+
:<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
415432
:<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
416433
, Header "Set-Cookie" SetCookie ] NoContent)
417434
:<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
@@ -489,6 +506,11 @@ server ccfg =
489506
:<|> raw
490507
Indefinite -> throwAll err401
491508
_ -> throwAll err403
509+
) :<|>
510+
(\authResult -> case authResult of
511+
Authenticated usr -> respond (WithStatus @200 (42 :: Int))
512+
Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
513+
_ -> respond (WithStatus @403 $ pack "Forbidden")
492514
)
493515
:<|> getLogin
494516
:<|> getLogout
@@ -569,6 +591,12 @@ shouldMatchCookieNames cj patterns
569591
= fmap cookie_name (destroyCookieJar cj)
570592
`shouldMatchList` patterns
571593

594+
shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
595+
shouldNotHaveCookies cj patterns =
596+
sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
597+
where cookieNames :: [BS.ByteString]
598+
cookieNames = cookie_name <$> destroyCookieJar cj
599+
572600
shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
573601
shouldMatchCookieNameValues cj patterns
574602
= fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

‎servant/src/Servant/API/ResponseHeaders.hs

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE PolyKinds #-}
99
{-# LANGUAGE ScopedTypeVariables #-}
1010
{-# LANGUAGE TypeFamilies #-}
11+
{-# LANGUAGE TypeFamilyDependencies #-}
1112
{-# LANGUAGE TypeOperators #-}
1213
{-# LANGUAGE UndecidableInstances #-}
1314
{-# OPTIONS_HADDOCK not-home #-}
@@ -51,6 +52,9 @@ import Prelude ()
5152
import Prelude.Compat
5253
import Servant.API.Header
5354
(Header)
55+
import Servant.API.UVerb.Union
56+
import qualified Data.SOP.BasicFunctors as SOP
57+
import qualified Data.SOP.NS as SOP
5458

5559
-- | Response Header objects. You should never need to construct one directly.
5660
-- Instead, use 'addOptionalHeader'.
@@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '
170174
=> AddHeader h v a new where
171175
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
172176

177+
-- Instances to decorate all responses in a 'Union' with headers. The functional
178+
-- dependencies force us to consider singleton lists as the base case in the
179+
-- recursion (it is impossible to determine h and v otherwise from old / new
180+
-- responses if the list is empty).
181+
instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where
182+
addOptionalHeader hdr resp =
183+
SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
184+
185+
instance
186+
( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)
187+
-- This ensures that the remainder of the response list is _not_ empty
188+
-- It is necessary to prevent the two instances for union types from
189+
-- overlapping.
190+
, oldrest ~ (a ': as), newrest ~ (b ': bs))
191+
=> AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
192+
addOptionalHeader hdr resp = case resp of
193+
SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
194+
SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
195+
173196
-- | @addHeader@ adds a header to a response. Note that it changes the type of
174197
-- the value in the following ways:
175198
--

‎servant/src/Servant/API/UVerb.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a
9090
instance KnownStatus n => HasStatus (WithStatus n a) where
9191
type StatusOf (WithStatus n a) = n
9292

93+
instance HasStatus a => HasStatus (Headers ls a) where
94+
type StatusOf (Headers ls a) = StatusOf a
9395

9496
-- | A variant of 'Verb' that can have any of a number of response values and status codes.
9597
--

0 commit comments

Comments
 (0)