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

Support UVerb in servant-auth-server

Browse source
This commit is contained in:
Gaël Deest 2022-03-22 11:21:54 +01:00
parent af3dde1b1d
commit 030d852883
5 changed files with 41 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-auth/servant-auth-server/servant-auth-server.cabal
View file

@ -129,6 +129,7 @@ test-suite spec
, lens-aeson >= 1.0.2 && < 1.2
, warp >= 3.2.25 && < 3.4
, wreq >= 0.5.2.1 && < 0.6
, text >= 1.2.3.0 && < 2.1
other-modules:
Servant.Auth.ServerSpec
default-language: Haskell2010

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

@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))
import qualified Network.HTTP.Types as HTTP
import Network.Wai (mapResponseHeaders)
import Servant
import Servant.API.UVerb.Union
import Servant.API.Generic
import Servant.Server.Generic
import Web.Cookie
@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where
AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
#if MIN_VERSION_servant_server(0,18,1)
type family MapAddSetCookieApiVerb (as :: [*]) where
MapAddSetCookieApiVerb '[] = '[]
MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
#endif
type family AddSetCookieApi a :: *
type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
#if MIN_VERSION_servant_server(0,19,0)
type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
#endif
type instance AddSetCookieApi (Verb method stat ctyps a)
= Verb method stat ctyps (AddSetCookieApiVerb a)
#if MIN_VERSION_servant_server(0,18,1)
type instance AddSetCookieApi (UVerb method ctyps as)
= UVerb method ctyps (MapAddSetCookieApiVerb as)
#endif
type instance AddSetCookieApi Raw = Raw
#if MIN_VERSION_servant_server(0,15,0)
type instance AddSetCookieApi (Stream method stat framing ctyps a)
@ -57,7 +70,7 @@ 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
instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
addSetCookies _ = id
instance {-# OVERLAPPABLE #-}

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
module Servant.Auth.ServerSpec (spec) where
#if !MIN_VERSION_servant_server(0,16,0)
@ -25,6 +26,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,
import Data.Aeson.Lens (_JSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Text (Text)
import Data.CaseInsensitive (mk)
import Data.Foldable (find)
import Data.Monoid
@ -407,6 +409,7 @@ type API auths
( Get '[JSON] Int
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int
:<|> NamedRoutes DummyRoutes
:<|> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 500 Text]
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
#if MIN_VERSION_servant_server(0,15,0)
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
@ -483,6 +486,7 @@ server ccfg =
Authenticated usr -> getInt usr
:<|> postInt usr
:<|> DummyRoutes { dummyInt = getInt usr }
:<|> respond (WithStatus @200 (42 :: Int))
:<|> getHeaderInt
#if MIN_VERSION_servant_server(0,15,0)
:<|> return (S.source ["bytestring"])

19
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -8,6 +8,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@ -51,6 +52,9 @@ import Prelude ()
import Prelude.Compat
import Servant.API.Header
(Header)
import Servant.API.UVerb.Union
import qualified Data.SOP.BasicFunctors as SOP
import qualified Data.SOP.NS as SOP
-- | Response Header objects. You should never need to construct one directly.
-- Instead, use 'addOptionalHeader'.
@ -170,6 +174,21 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '
=> AddHeader h v a new where
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
-- Instances to decorate all responses in a 'Union' with headers. The functional
-- dependencies force us to consider singleton lists as the base case in the
-- recursion (it is impossible to determine h and v otherwise from old / new
-- responses if the list is empty).
instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where
addOptionalHeader hdr resp =
SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
instance
(AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest), oldrest ~ (a ': as), newrest ~ (b ': bs))
=> AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
addOptionalHeader hdr resp = case resp of
SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
-- | @addHeader@ adds a header to a response. Note that it changes the type of
-- the value in the following ways:
--

3
servant/src/Servant/API/UVerb.hs
View file

@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)
import Network.HTTP.Types (Status, StdMethod)
import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
import Servant.API.Status (KnownStatus, statusVal)
import Servant.API.ResponseHeaders (Headers)
import Servant.API.UVerb.Union
class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a
instance KnownStatus n => HasStatus (WithStatus n a) where
type StatusOf (WithStatus n a) = n
instance HasStatus a => HasStatus (Headers ls a) where
type StatusOf (Headers ls a) = StatusOf a
-- | A variant of 'Verb' that can have any of a number of response values and status codes.
--