From 3001ed799053524495026bb236c8e76001c250e8 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 9 Nov 2018 21:49:53 +0200 Subject: [PATCH] Add mods to StreamBody --- .../Servant/Client/Core/Internal/HasClient.hs | 6 +++--- servant-docs/src/Servant/Docs/Internal.hs | 2 +- .../src/Servant/Foreign/Internal.hs | 4 ++-- servant-server/src/Servant/Server/Internal.hs | 6 +++--- servant-server/test/Servant/ServerSpec.hs | 20 ++++++++++--------- servant/src/Servant/API.hs | 14 ++++++------- servant/src/Servant/API/Stream.hs | 7 ++++--- servant/src/Servant/Links.hs | 6 +++--- servant/src/Servant/Test/ComprehensiveAPI.hs | 2 +- 9 files changed, 35 insertions(+), 32 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 617e404e..71200700 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -40,7 +40,7 @@ import Servant.API Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody, Summary, ToHttpApiData, + ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, Vault, Verb, WithNamedContext, contentType, getHeadersHList, getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes @@ -539,10 +539,10 @@ instance (MimeRender ct a, HasClient m api) instance ( HasClient m api - ) => HasClient m (StreamBody framing ctype a :> api) + ) => HasClient m (StreamBody' mods framing ctype a :> api) where - type Client m (StreamBody framing ctype a :> api) = a -> Client m api + type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 6c96292b..6452ea80 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -980,7 +980,7 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) p = Proxy :: Proxy a -- | TODO: this instance is incomplete. -instance (HasDocs api, Accept ctype) => HasDocs (StreamBody framing ctype a :> api) where +instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods framing ctype a :> api) where docsFor Proxy (endpoint, action) opts = docsFor subApiP (endpoint, action') opts where diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index cc867b4f..486177d3 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -328,9 +328,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api instance ( HasForeign lang ftype api - ) => HasForeign lang ftype (StreamBody framing ctype a :> api) + ) => HasForeign lang ftype (StreamBody' mods framing ctype a :> api) where - type Foreign ftype (StreamBody framing ctype a :> api) = Foreign ftype api + type Foreign ftype (StreamBody' mods framing ctype a :> api) = Foreign ftype api foreignFor _lang Proxy Proxy _req = error "HasForeign @StreamBody" diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index f36cef49..03231508 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -71,7 +71,7 @@ import Servant.API FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', - SBool (..), SBoolI (..), SourceIO, Stream, StreamBody, + SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -610,9 +610,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods instance ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk , HasServer api context - ) => HasServer (StreamBody framing ctype a :> api) context + ) => HasServer (StreamBody' mods framing ctype a :> api) context where - type ServerT (StreamBody framing ctype a :> api) m = a -> ServerT api m + type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 777097f1..d940542e 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -12,24 +12,26 @@ module Servant.ServerSpec where +import Prelude () +import Prelude.Compat + import Control.Monad (forM_, unless, when) import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) -import Data.Monoid import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) -import qualified Data.Text as T +import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types @@ -42,25 +44,25 @@ import Network.Wai import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) -import qualified Servant.Types.SourceT as S import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete, EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, - RemoteHost, ReqBody, StdMethod (..), Stream, - SourceIO, Verb, addHeader) -import Servant.Test.ComprehensiveAPI + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb, + addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, serve, serveWithContext) +import Servant.Test.ComprehensiveAPI +import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) -import qualified Test.Hspec.Wai as THW +import qualified Test.Hspec.Wai as THW import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 29f6e2ec..b9c1c78b 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -110,14 +110,14 @@ import Servant.API.ReqBody (ReqBody, ReqBody') import Servant.API.ResponseHeaders (AddHeader, BuildHeadersTo (buildHeadersTo), - GetHeaders (getHeaders), HList (..), Headers (..), - ResponseHeader (..), addHeader, getHeadersHList, getResponse, - noHeader, HasResponseHeader, lookupResponseHeader) + GetHeaders (getHeaders), HList (..), HasResponseHeader, + Headers (..), ResponseHeader (..), addHeader, getHeadersHList, + getResponse, lookupResponseHeader, noHeader) import Servant.API.Stream - (FramingRender (..), FramingUnrender (..), - FromSourceIO (..), NetstringFraming, NewlineFraming, - NoFraming, SourceIO, Stream, StreamBody, SourceIO, - StreamGet, StreamPost, ToSourceIO (..)) + (FramingRender (..), FramingUnrender (..), FromSourceIO (..), + NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream, + StreamBody, StreamBody', StreamGet, StreamPost, + ToSourceIO (..)) import Servant.API.Sub ((:>)) import Servant.API.Vault diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 7393f098..379a8d47 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -17,6 +17,7 @@ module Servant.API.Stream ( StreamGet, StreamPost, StreamBody, + StreamBody', -- * Source -- -- | 'SourceIO' are equivalent to some *source* in streaming libraries. @@ -71,9 +72,9 @@ type StreamGet = Stream 'GET 200 type StreamPost = Stream 'POST 200 -- | A stream request body. --- --- TODO: add mods -data StreamBody (framing :: *) (contentType :: *) (a :: *) +type StreamBody = StreamBody' '[] + +data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *) deriving (Typeable, Generic) ------------------------------------------------------------------------------- diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 61138aeb..77f882df 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -170,7 +170,7 @@ import Servant.API.RemoteHost import Servant.API.ReqBody (ReqBody') import Servant.API.Stream - (Stream, StreamBody) + (Stream, StreamBody') import Servant.API.Sub (type (:>)) import Servant.API.TypeLevel @@ -482,8 +482,8 @@ instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) -instance HasLink sub => HasLink (StreamBody framing ct a :> sub) where - type MkLink (StreamBody framing ct a :> sub) r = MkLink sub r +instance HasLink sub => HasLink (StreamBody' mods framing ct a :> sub) where + type MkLink (StreamBody' mods framing ct a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) instance (ToHttpApiData v, HasLink sub) diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index cd643784..51721c3a 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -22,7 +22,7 @@ type RawEndpoint = "raw" :> Raw type StreamingEndpoint = - "streaming" :> StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) + "streaming" :> StreamBody' '[Description "netstring"] NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) type EmptyEndpoint = "empty-api" :> EmptyAPI