master...b84095e · typeable/servant

git.iko.soy/typeable/servant

6 files changed+53−1

since splitsnapshots

unifiedsplit

changelog.d/1571+8 servant-auth/servant-auth-server/servant-auth-server.cabal+1 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+4 servant/src/Servant/API/ResponseHeaders.hs+23 servant/src/Servant/API/UVerb.hs+3

changelog.d/1571new file+8

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

129129 , lens-aeson >= 1.0.2 && < 1.2

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/AddSetCookie.hs+14−1

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

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14+import Servant.API.UVerb.Union

1415import Servant.API.Generic

1516import Servant.Server.Generic

1617import 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+

3643type family AddSetCookieApi a :: *

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

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

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

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

48+#endif

4049type 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

4255type instance AddSetCookieApi Raw = Raw

4356#if MIN_VERSION_servant_server(0,15,0)

4457type 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

6376instance {-# OVERLAPPABLE #-}

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+4

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

23module Servant.Auth.ServerSpec (spec) where

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

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

2526import Data.Aeson.Lens (_JSON)

2627import qualified Data.ByteString as BS

2728import qualified Data.ByteString.Lazy as BSL

29+import Data.Text (Text)

2830import Data.CaseInsensitive (mk)

2931import Data.Foldable (find)

3032import Data.Monoid

@@ -407,6 +409,7 @@ type API auths

407409 ( Get '[JSON] Int

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

409411 :<|> NamedRoutes DummyRoutes

412+ :<|> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 500 Text]

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

411414#if MIN_VERSION_servant_server(0,15,0)

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

@@ -483,6 +486,7 @@ server ccfg =

483486 Authenticated usr -> getInt usr

484487 :<|> postInt usr

485488 :<|> DummyRoutes { dummyInt = getInt usr }

489+ :<|> respond (WithStatus @200 (42 :: Int))

486490 :<|> getHeaderInt

487491#if MIN_VERSION_servant_server(0,15,0)

488492 :<|> return (S.source ["bytestring"])

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

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

5152import Prelude.Compat

5253import 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+3

@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)

3838import Network.HTTP.Types (Status, StdMethod)

3939import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))

4040import Servant.API.Status (KnownStatus, statusVal)

41+import Servant.API.ResponseHeaders (Headers)

4142import Servant.API.UVerb.Union

4243

4344class KnownStatus (StatusOf a) => HasStatus (a :: *) where

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

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

8788 type StatusOf (WithStatus n a) = n

8889

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

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

8992

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

9194--