aee1917 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Support UVerb in servant-auth-server (#1571)

aee1917Gaël Deest4 years ago

changelog.d/1571new file+8

compare with master

unifiedsplit

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

@@ -129,6 +129,7 @@ test-suite spec

129 , lens-aeson >= 1.0.2 && < 1.3

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132 other-modules:

133 other-modules:

133 Servant.Auth.ServerSpec

134 Servant.Auth.ServerSpec

134 default-language: Haskell2010

135 default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9

@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)

55 makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56 makeCookies authResult = do

57− xsrf <- makeXsrfCookie cookieSettings

58− fmap (Just xsrf `SetCookieCons`) $

59− case authResult of

57+ case authResult of

60− (Authenticated v) -> do

58+ (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

60+ xsrf <- makeXsrfCookie cookieSettings

63− Nothing -> return $ Nothing `SetCookieCons` SetCookieNil

64− Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil

61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)

65− _ -> return $ Nothing `SetCookieCons` SetCookieNil

62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)

67 go :: (AuthResult v -> ServerT api Handler)

64 go :: (AuthResult v -> ServerT api Handler)

68 -> (AuthResult v, SetCookieList n)

65 -> (AuthResult v, SetCookieList n)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1

@@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.UVerb.Union

14import Servant.API.Generic

15import Servant.API.Generic

15import Servant.Server.Generic

16import Servant.Server.Generic

16import Web.Cookie

17import Web.Cookie

@@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where

33 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

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+

36type family AddSetCookieApi a :: *

43type family AddSetCookieApi a :: *

37type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

44type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

38type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

45type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

46+#if MIN_VERSION_servant_server(0,19,0)

39type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

47type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

48+#endif

40type instance AddSetCookieApi (Verb method stat ctyps a)

49type instance AddSetCookieApi (Verb method stat ctyps a)

41 = Verb method stat ctyps (AddSetCookieApiVerb a)

50 = 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

42type instance AddSetCookieApi Raw = Raw

55type instance AddSetCookieApi Raw = Raw

43#if MIN_VERSION_servant_server(0,15,0)

56#if MIN_VERSION_servant_server(0,15,0)

44type instance AddSetCookieApi (Stream method stat framing ctyps a)

57type instance AddSetCookieApi (Stream method stat framing ctyps a)

@@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

57 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

70 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

58 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

60−instance AddSetCookies 'Z orig orig where

73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where

61 addSetCookies _ = id

74 addSetCookies _ = id

63instance {-# OVERLAPPABLE #-}

76instance {-# OVERLAPPABLE #-}

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+31−3

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

2module Servant.Auth.ServerSpec (spec) where

3module Servant.Auth.ServerSpec (spec) where

4#if !MIN_VERSION_servant_server(0,16,0)

5#if !MIN_VERSION_servant_server(0,16,0)

@@ -24,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,

24import Data.Aeson.Lens (_JSON)

25import Data.Aeson.Lens (_JSON)

25import qualified Data.ByteString as BS

26import qualified Data.ByteString as BS

26import qualified Data.ByteString.Lazy as BSL

27import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

27import Data.CaseInsensitive (mk)

29import Data.CaseInsensitive (mk)

28import Data.Foldable (find)

30import Data.Foldable (find)

29import Data.Monoid

31import Data.Monoid

@@ -39,6 +41,7 @@ import Network.HTTP.Types (Status, status200,

39import Network.Wai (responseLBS)

41import Network.Wai (responseLBS)

40import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wai.Handler.Warp (testWithApplication)

41import Network.Wreq (Options, auth, basicAuth,

43import Network.Wreq (Options, auth, basicAuth,

44+ checkResponse,

42 cookieExpiryTime, cookies,

45 cookieExpiryTime, cookies,

43 defaults, get, getWith, postWith,

46 defaults, get, getWith, postWith,

44 header, oauth2Bearer,

47 header, oauth2Bearer,

@@ -182,8 +185,21 @@ cookieAuthSpec

182 it "fails with no XSRF header or cookie" $ \port -> property

185 it "fails with no XSRF header or cookie" $ \port -> property

183 $ \(user :: User) -> do

186 $ \(user :: User) -> do

184 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

185− opts <- addJwtToCookie cookieCfg jwt

188+ opts' <- addJwtToCookie cookieCfg jwt

189+ let opts = opts' & checkResponse .~ Just mempty

186− getWith opts (url port) `shouldHTTPErrorWith` status401

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+

187

203

188 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

204 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

189 $ \(user :: User) -> do

205 $ \(user :: User) -> do

@@ -405,13 +421,14 @@ type API auths

405 = Auth auths User :>

421 = Auth auths User :>

406 ( Get '[JSON] Int

422 ( Get '[JSON] Int

407 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

423 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

408− :<|> NamedRoutes DummyRoutes

424+ :<|> "named" :> NamedRoutes DummyRoutes

409 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

425 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

410#if MIN_VERSION_servant_server(0,15,0)

426#if MIN_VERSION_servant_server(0,15,0)

411 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

427 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

412#endif

428#endif

413 :<|> "raw" :> Raw

429 :<|> "raw" :> Raw

414 )

430 )

431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

415 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

432 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

416 , Header "Set-Cookie" SetCookie ] NoContent)

433 , Header "Set-Cookie" SetCookie ] NoContent)

417 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

434 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

@@ -489,6 +506,11 @@ server ccfg =

489 :<|> raw

506 :<|> raw

490 Indefinite -> throwAll err401

507 Indefinite -> throwAll err401

491 _ -> throwAll err403

508 _ -> 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")

492 )

514 )

493 :<|> getLogin

515 :<|> getLogin

494 :<|> getLogout

516 :<|> getLogout

@@ -569,6 +591,12 @@ shouldMatchCookieNames cj patterns

569 = fmap cookie_name (destroyCookieJar cj)

591 = fmap cookie_name (destroyCookieJar cj)

570 `shouldMatchList` patterns

592 `shouldMatchList` patterns

571

593

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+

572shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

600shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

573shouldMatchCookieNameValues cj patterns

601shouldMatchCookieNameValues cj patterns

574 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

602 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

servant/src/Servant/API/ResponseHeaders.hs+23

@@ -8,6 +8,7 @@

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13{-# OPTIONS_HADDOCK not-home #-}

14{-# OPTIONS_HADDOCK not-home #-}

@@ -51,6 +52,9 @@ import Prelude ()

51import Prelude.Compat

52import Prelude.Compat

52import Servant.API.Header

53import Servant.API.Header

53 (Header)

54 (Header)

55+import Servant.API.UVerb.Union

56+import qualified Data.SOP.BasicFunctors as SOP

57+import qualified Data.SOP.NS as SOP

55-- | Response Header objects. You should never need to construct one directly.

59-- | Response Header objects. You should never need to construct one directly.

56-- Instead, use 'addOptionalHeader'.

60-- Instead, use 'addOptionalHeader'.

@@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '

170 => AddHeader h v a new where

174 => AddHeader h v a new where

171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

172

176

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+

173-- | @addHeader@ adds a header to a response. Note that it changes the type of

196-- | @addHeader@ adds a header to a response. Note that it changes the type of

174-- the value in the following ways:

197-- the value in the following ways:

175--

198--

servant/src/Servant/API/UVerb.hs+2

@@ -90,6 +90,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a

90instance KnownStatus n => HasStatus (WithStatus n a) where

91 type StatusOf (WithStatus n a) = n

93+instance HasStatus a => HasStatus (Headers ls a) where

94+ type StatusOf (Headers ls a) = StatusOf a

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

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

95--

97--