Support UVerb in servant-auth-server
This commit is contained in:
parent
af3dde1b1d
commit
030d852883
5 changed files with 41 additions and 1 deletions
|
@ -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
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
|
@ -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"])
|
||||
|
|
|
@ -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:
|
||||
--
|
||||
|
|
|
@ -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.
|
||||
--
|
||||
|
|
Loading…
Reference in a new issue