diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index d515d120..f9e087f5 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +14,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 +#define HAS_TYPE_ERROR +#endif + module Servant.Client.Core.HasClient ( clientIn, HasClient (..), @@ -63,17 +68,18 @@ import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, BuildHeadersTo (..), Capture', CaptureAll, Description, - EmptyAPI, FramingRender (..), FramingUnrender (..), + EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), - MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, - QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, - ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext, - contentType, getHeadersHList, getResponse, toQueryParam, - toUrlPiece) + MimeUnrender (mimeUnrender), NoContent (NoContent), + NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, + ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, + StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, + Verb, WithNamedContext, contentType, getHeadersHList, + getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) +import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) import Servant.API.UVerb @@ -745,6 +751,34 @@ instance ( HasClient m api hoistClientMonad pm _ f cl = \authreq -> hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) +-- | Ignore @'Fragment'@ in client functions. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +#ifdef HAS_TYPE_ERROR +instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api +#else +instance ( HasClient m api +#endif + ) => HasClient m (Fragment a :> api) where + + type Client m (Fragment a :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) + -- * Basic Authentication instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 0864896d..4b70a7a9 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -27,20 +27,22 @@ import Control.Concurrent import Control.Monad.Error.Class (throwError) import Data.Aeson -import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) import Data.Monoid () import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text + (Text) +import qualified Data.Text as Text +import Data.Text.Encoding + (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Network.Socket -import qualified Network.Wai as Wai +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) @@ -50,15 +52,14 @@ import Web.FormUrlEncoded import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, - DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, MimeRender(mimeRender), - MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText, - Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, - StdMethod(GET), Union, UVerb, WithStatus(WithStatus), - addHeader) + BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, + EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers, + JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), + NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union, + WithStatus (WithStatus), addHeader) import Servant.Client -import qualified Servant.Client.Core.Auth as Auth +import qualified Servant.Client.Core.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -109,6 +110,7 @@ type Api = :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "fragment" :> Fragment String :> Get '[JSON] Person :<|> "rawSuccess" :> Raw :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw @@ -141,6 +143,7 @@ getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool +getFragment :: ClientM Person getRawSuccess :: HTTP.Method -> ClientM Response getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response @@ -163,6 +166,7 @@ getRoot :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag + :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders :<|> getRawFailure @@ -188,6 +192,7 @@ server = serve api ( Nothing -> throwError $ ServerError 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return + :<|> return alice :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 9e12f034..bb9d47dc 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -34,20 +34,21 @@ import Data.Maybe import Data.Monoid () import Data.Text (Text) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck import Servant.API - (NoContent (NoContent), WithStatus(WithStatus), getHeaders) + (NoContent (NoContent), WithStatus (WithStatus), getHeaders) import Servant.Client -import qualified Servant.Client.Core.Request as Req -import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) -import Servant.Test.ComprehensiveAPI +import qualified Servant.Client.Core.Request as Req +import Servant.Client.Internal.HttpClient + (defaultMakeClientRequest) import Servant.ClientTestUtils +import Servant.Test.ComprehensiveAPI -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming @@ -103,6 +104,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + it "Servant.API.Fragment" $ \(_, baseUrl) -> do + left id <$> runClient getFragment baseUrl `shouldReturn` Right alice it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md index 5bb7c4e9..7d224502 100644 --- a/servant-docs/golden/comprehensive.md +++ b/servant-docs/golden/comprehensive.md @@ -182,6 +182,28 @@ ``` +## GET /fragment + +### Fragment: + +- *foo*: Fragment Int + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + ## GET /get-int ### Response: diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index e9e95692..b36ad88b 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -25,8 +25,8 @@ import Control.Applicative import Control.Arrow (second) import Control.Lens - (makeLenses, mapped, over, traversed, view, (%~), (&), (.~), - (<>~), (^.), (|>)) + (makeLenses, mapped, over, set, traversed, view, (%~), (&), + (.~), (<>~), (^.), (|>)) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Lazy.Char8 (ByteString) @@ -64,7 +64,7 @@ import Servant.API import Servant.API.ContentTypes import Servant.API.TypeLevel -import qualified Data.Universe.Helpers as U +import qualified Data.Universe.Helpers as U import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -161,6 +161,20 @@ data DocQueryParam = DocQueryParam , _paramKind :: ParamKind } deriving (Eq, Ord, Show) +-- | A type to represent fragment. Holds the name of the fragment and its description. +-- +-- Write a 'ToFragment' instance for your fragment types. +data DocFragment = DocFragment + { _fragSymbol :: String -- type supplied + , _fragDesc :: String -- user supplied + } deriving (Eq, Ord, Show) + +-- | There should be at most one 'Fragment' per API endpoint. +-- So here we are keeping the first occurrence. +combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment +Nothing `combineFragment` mdocFragment = mdocFragment +Just docFragment `combineFragment` _ = Just docFragment + -- | An introductory paragraph for your documentation. You can pass these to -- 'docsWithIntros'. data DocIntro = DocIntro @@ -283,6 +297,7 @@ data Action = Action , _captures :: [DocCapture] -- type collected + user supplied info , _headers :: [Text] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info + , _fragment :: Maybe DocFragment -- type collected + user supplied info , _notes :: [DocNote] -- user supplied , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info , _rqtypes :: [M.MediaType] -- type collected @@ -296,8 +311,9 @@ data Action = Action -- As such, we invent a non-commutative, left associative operation -- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action -Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' = - Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') +Action a c h p f n m ts body resp + `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' = + Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') -- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. @@ -305,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod -- Tweakable with lenses. -- -- >>> defAction --- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}} +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}} -- -- >>> defAction & response.respStatus .~ 201 --- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}} +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}} -- defAction :: Action defAction = @@ -316,6 +332,7 @@ defAction = [] [] [] + Nothing [] [] [] @@ -368,6 +385,7 @@ makeLenses ''API makeLenses ''Endpoint makeLenses ''DocCapture makeLenses ''DocQueryParam +makeLenses ''DocFragment makeLenses ''DocIntro makeLenses ''DocNote makeLenses ''Response @@ -587,6 +605,15 @@ class ToCapture c where class ToAuthInfo a where toAuthInfo :: Proxy a -> DocAuthentication +-- | The class that helps us get documentation for URL fragments. +-- +-- Example of an instance: +-- +-- > instance ToFragment (Fragment a) where +-- > toFragment _ = DocFragment "fragment" "fragment description" +class ToFragment t where + toFragment :: Proxy t -> DocFragment + -- | Generate documentation in Markdown format for -- the given 'API'. -- @@ -629,6 +656,7 @@ markdownWith RenderingOptions{..} api = unlines $ capturesStr (action ^. captures) ++ headersStr (action ^. headers) ++ paramsStr meth (action ^. params) ++ + fragmentStr (action ^. fragment) ++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ responseStr (action ^. response) ++ [] @@ -730,6 +758,14 @@ markdownWith RenderingOptions{..} api = unlines $ where values = param ^. paramValues + fragmentStr :: Maybe DocFragment -> [String] + fragmentStr Nothing = [] + fragmentStr (Just frag) = + [ "### Fragment:", "" + , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc) + , "" + ] + rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] rqbodyStr types s = @@ -959,6 +995,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api) paramP = Proxy :: Proxy (QueryFlag sym) action' = over params (|> toParam paramP) action +instance (ToFragment (Fragment a), HasDocs api) + => HasDocs (Fragment a :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + where subApiP = Proxy :: Proxy api + fragmentP = Proxy :: Proxy (Fragment a) + action' = set fragment (Just (toFragment fragmentP)) action instance HasDocs Raw where docsFor _proxy (endpoint, action) _ = diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 8a297b4d..5da5ff4d 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where toCapture _ = DocCapture "foo" "Capture foo Int" instance ToCapture (CaptureAll "foo" Int) where toCapture _ = DocCapture "foo" "Capture all foo Int" +instance ToFragment (Fragment Int) where + toFragment _ = DocFragment "foo" "Fragment Int" -- * specs diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 0f3b1248..22f37ad9 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -84,6 +84,11 @@ captureArg _ = error "captureArg called on non capture" type Path f = [Segment f] +newtype Frag f = Frag { unFragment :: Arg f } + deriving (Data, Eq, Show, Typeable) + +makePrisms ''Frag + data ArgType = Normal | Flag @@ -115,11 +120,12 @@ makePrisms ''HeaderArg data Url f = Url { _path :: Path f , _queryStr :: [QueryArg f] + , _frag :: Maybe f } deriving (Data, Eq, Show, Typeable) defUrl :: Url f -defUrl = Url [] [] +defUrl = Url [] [] Nothing makeLenses ''Url @@ -324,6 +330,16 @@ instance { _argName = PathSegment str , _argType = typeFor lang ftype (Proxy :: Proxy Bool) } +instance + (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api) + => HasForeign lang ftype (Fragment a :> api) where + type Foreign ftype (Fragment a :> api) = Foreign ftype api + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ + req & reqUrl . frag .~ Just argT + where + argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a)) + instance HasForeign lang ftype Raw where type Foreign ftype Raw = HTTP.Method -> Req ftype diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 76fb5351..3baaf7b6 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -14,8 +14,8 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy -import Servant.Test.ComprehensiveAPI import Servant.Foreign +import Servant.Test.ComprehensiveAPI import Servant.Types.SourceT (SourceT) @@ -91,6 +91,7 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "flag" "boolX") Flag ] + Nothing , _reqMethod = "GET" , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"] , _reqBody = Nothing @@ -103,6 +104,7 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "param" "maybe intX") Normal ] + Nothing , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX" @@ -116,6 +118,7 @@ listFromAPISpec = describe "listFromAPI" $ do [ Segment $ Static "test" ] -- Should this be |intX| or |listX of intX| ? [ QueryArg (Arg "params" "listX of intX") List ] + Nothing , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX" @@ -129,6 +132,7 @@ listFromAPISpec = describe "listFromAPI" $ do [ Segment $ Static "test" , Segment $ Cap (Arg "id" "intX") ] [] + Nothing , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing @@ -142,6 +146,7 @@ listFromAPISpec = describe "listFromAPI" $ do [ Segment $ Static "test" , Segment $ Cap (Arg "ids" "listX of intX") ] [] + Nothing , _reqMethod = "GET" , _reqHeaders = [] , _reqBody = Nothing diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index ba42c8e9..8ebfa9a1 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -71,17 +71,17 @@ import Prelude () import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', - CaptureAll, Description, EmptyAPI, FramingRender (..), - FramingUnrender (..), FromSourceIO (..), Header', If, - IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw, - ReflectMethod (reflectMethod), RemoteHost, ReqBody', - SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', - Summary, ToSourceIO (..), Vault, Verb, NoContentVerb, + CaptureAll, Description, EmptyAPI, Fragment, + FramingRender (..), FramingUnrender (..), FromSourceIO (..), + Header', If, IsSecure (..), NoContentVerb, QueryFlag, + QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), + RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, + Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), - AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH, - NoContent) + AllMime, MimeRender (..), MimeUnrender (..), NoContent, + canHandleAcceptH) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) @@ -89,8 +89,8 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import qualified Servant.Types.SourceT as S import Web.HttpApiData - (FromHttpApiData, parseHeader, parseQueryParam, - parseUrlPieces, parseUrlPiece) + (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, + parseUrlPieces) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context @@ -106,6 +106,8 @@ import Servant.Server.Internal.ServerError #ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) +import Servant.API.TypeLevel + (AtLeastOneFragment, FragmentUnique) #endif class HasServer api context where @@ -880,5 +882,28 @@ type HasServerArrowTypeError a b = ':$$: 'ShowType b #endif +-- | Ignore @'Fragment'@ in server handlers. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Handler [Book] +-- > getBooksBy = ...return all books... +#ifdef HAS_TYPE_ERROR +instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) +#else +instance (HasServer api context) +#endif + => HasServer (Fragment a1 :> api) context where + type ServerT (Fragment a1 :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + + hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api) + -- $setup -- >>> import Servant diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 80210495..04443c9d 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where import Prelude () import Prelude.Compat -import Control.Exception hiding +import Control.Exception hiding (Handler) import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -28,7 +28,7 @@ import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) -import qualified Data.Text as T +import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 87c84421..e3dec48e 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -48,12 +48,12 @@ import Network.Wai.Test import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers, - HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), - NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, - Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, - ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union, - UVerb, Verb, addHeader) + Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, + Headers, HttpVersion, IsSecure (..), JSON, Lenient, + NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, + UVerb, Union, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, respond, serve, @@ -92,6 +92,7 @@ spec = do captureSpec captureAllSpec queryParamSpec + fragmentSpec reqBodySpec headerSpec rawSpec @@ -461,6 +462,37 @@ queryParamSpec = do { name = "Alice" } +-- }}} +------------------------------------------------------------------------------ +-- * fragmentSpec {{{ +------------------------------------------------------------------------------ + +type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person + :<|> "age" :> Fragment Integer :> Get '[JSON] Person + +fragmentApi :: Proxy FragmentApi +fragmentApi = Proxy + +fragServer :: Server FragmentApi +fragServer = fragmentServer :<|> fragAge + where + fragmentServer = return alice + fragAge = return alice + +fragmentSpec :: Spec +fragmentSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + + describe "Servant.API.Fragment" $ do + it "ignores fragment even if it is present in query" $ do + flip runSession (serve fragmentApi fragServer) $ do + response1 <- mkRequest "#Alice" ["name"] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + -- }}} ------------------------------------------------------------------------------ -- * reqBodySpec {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 79fcd5ff..469f6cec 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -40,6 +40,7 @@ library Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth + Servant.API.Fragment Servant.API.Generic Servant.API.Header Servant.API.HttpVersion diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 66b86d78..deb974ae 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -19,6 +19,8 @@ module Servant.API ( -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ + module Servant.API.Fragment, + -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.RemoteHost, @@ -93,6 +95,8 @@ import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Fragment + (Fragment) import Servant.API.Header (Header, Header') import Servant.API.HttpVersion @@ -121,21 +125,20 @@ import Servant.API.Stream ToSourceIO (..)) import Servant.API.Sub ((:>)) +import Servant.API.UVerb + (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union, + Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent, - Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, - Post, PostAccepted, PostCreated, PostNoContent, - PostNonAuthoritative, PostResetContent, Put, PutAccepted, - PutCreated, PutNoContent, PutNonAuthoritative, - ReflectMethod (reflectMethod), StdMethod (..), - Verb, NoContentVerb) -import Servant.API.UVerb - (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses, - WithStatus (..), IsMember, Unique, inject) + NoContentVerb, Patch, PatchAccepted, PatchNoContent, + PatchNonAuthoritative, Post, PostAccepted, PostCreated, + PostNoContent, PostNonAuthoritative, PostResetContent, Put, + PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Links diff --git a/servant/src/Servant/API/Fragment.hs b/servant/src/Servant/API/Fragment.hs new file mode 100644 index 00000000..dd9befaa --- /dev/null +++ b/servant/src/Servant/API/Fragment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Fragment (Fragment) where + +import Data.Typeable + (Typeable) + +-- | Document the URI fragment in API. Useful in combination with 'Link'. +-- +-- Example: +-- +-- >>> -- /post#TRACKING +-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking +data Fragment (a :: *) + deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Tracking +-- >>> instance ToJSON Tracking where { toJSON = undefined } diff --git a/servant/src/Servant/API/Modifiers.hs b/servant/src/Servant/API/Modifiers.hs index 7979ac15..3714fd3a 100644 --- a/servant/src/Servant/API/Modifiers.hs +++ b/servant/src/Servant/API/Modifiers.hs @@ -131,8 +131,6 @@ type RequestArgument mods a = (If (FoldLenient mods) (Either Text a) a) (Maybe (If (FoldLenient mods) (Either Text a) a)) - - -- | Unfold a value into a 'RequestArgument'. unfoldRequestArgument :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 79ff287a..4a5e3c3b 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-| This module collects utilities for manipulating @servant@ API types. The @@ -41,6 +45,9 @@ module Servant.API.TypeLevel ( -- ** Logic Or, And, + -- ** Fragment + FragmentUnique, + AtLeastOneFragment ) where @@ -50,6 +57,7 @@ import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) +import Servant.API.Fragment import Servant.API.Header (Header) import Servant.API.QueryParam @@ -60,6 +68,8 @@ import Servant.API.Sub (type (:>)) import Servant.API.Verbs (Verb) +import Servant.API.UVerb + (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -128,6 +138,7 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem sa (Fragment x :> sb) = IsElem sa sb IsElem (Verb m s ct typ) (Verb m s ct' typ) = IsSubList ct ct' IsElem e e = () @@ -241,6 +252,43 @@ We might try to factor these our more cleanly, but the type synonyms and type families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -} +-- ** Fragment + +class FragmentUnique api => AtLeastOneFragment api + +-- | If fragment appeared in API endpoint twice, compile-time error would be raised. +-- +-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent +-- >>> instance AtLeastOneFragment FailAPI +-- ... +-- ...Only one Fragment allowed per endpoint in api... +-- ... +-- ...In the instance declaration for... +instance AtLeastOneFragment (Verb m s ct typ) + +instance AtLeastOneFragment (UVerb m cts as) + +instance AtLeastOneFragment (Fragment a) + +type family FragmentUnique api :: Constraint where + FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb) + FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa) + FragmentUnique (x :> sa) = FragmentUnique sa + FragmentUnique (Fragment a) = () + FragmentUnique x = () + +type family FragmentNotIn api orig :: Constraint where + FragmentNotIn (sa :<|> sb) orig = + And (FragmentNotIn sa orig) (FragmentNotIn sb orig) + FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig + FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn x orig = () + +type NotUniqueFragmentInApi api = + 'Text "Only one Fragment allowed per endpoint in api ‘" + ':<>: 'ShowType api + ':<>: 'Text "’." -- $setup -- @@ -248,6 +296,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs +-- >>> :set -XTypeSynonymInstances -XFlexibleInstances -- >>> import Data.Proxy -- >>> import Data.Type.Equality -- >>> import Servant.API @@ -255,4 +304,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- >>> instance Show (OK ctx) where show _ = "OK" -- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK -- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent -- >>> let sampleAPI = Proxy :: Proxy SampleAPI diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index b42738e2..39a228d7 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -120,6 +120,7 @@ module Servant.Links ( , Param (..) , linkSegments , linkQueryParams + , linkFragment ) where import Data.List @@ -152,6 +153,8 @@ import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Fragment + (Fragment) import Servant.API.Generic import Servant.API.Header (Header') @@ -188,10 +191,13 @@ import Web.HttpApiData data Link = Link { _segments :: [Escaped] , _queryParams :: [Param] + , _fragment :: Fragment' } deriving Show newtype Escaped = Escaped String +type Fragment' = Maybe String + escaped :: String -> Escaped escaped = Escaped . escapeURIString isUnreserved @@ -208,11 +214,14 @@ linkSegments = map getEscaped . _segments linkQueryParams :: Link -> [Param] linkQueryParams = _queryParams +linkFragment :: Link -> Fragment' +linkFragment = _fragment + instance ToHttpApiData Link where toHeader = TE.encodeUtf8 . toUrlPiece toUrlPiece l = let uri = linkURI l - in Text.pack $ uriPath uri ++ uriQuery uri + in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri -- | Query parameter. data Param @@ -228,6 +237,9 @@ addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } +addFragment :: Fragment' -> Link -> Link +addFragment fr l = l { _fragment = fr } + -- | Transform 'Link' into 'URI'. -- -- >>> type API = "something" :> Get '[JSON] Int @@ -245,7 +257,7 @@ addQueryParam qp l = -- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] () -- >>> let someRoute = Proxy :: Proxy SomeRoute -- >>> safeLink someRoute someRoute "test@example.com" --- Link {_segments = ["abc","test%40example.com"], _queryParams = []} +-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing} -- -- >>> linkURI $ safeLink someRoute someRoute "test@example.com" -- abc/test%40example.com @@ -269,11 +281,12 @@ data LinkArrayElementStyle -- sum?x=1&x=2&x=3 -- linkURI' :: LinkArrayElementStyle -> Link -> URI -linkURI' addBrackets (Link segments q_params) = +linkURI' addBrackets (Link segments q_params mfragment) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative) (intercalate "/" $ map getEscaped segments) - (makeQueries q_params) mempty + (makeQueries q_params) + (makeFragment mfragment) where makeQueries :: [Param] -> String makeQueries [] = "" @@ -285,6 +298,10 @@ linkURI' addBrackets (Link segments q_params) = makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k + makeFragment :: Fragment' -> String + makeFragment Nothing = "" + makeFragment (Just fr) = "#" <> escape fr + style = case addBrackets of LinkArrayElementBracket -> "[]=" LinkArrayElementPlain -> "=" @@ -310,7 +327,7 @@ safeLink' -> Proxy api -- ^ The whole API that this endpoint is a part of -> Proxy endpoint -- ^ The API endpoint you would like to point to -> MkLink endpoint a -safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty) +safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty) -- | Create all links in an API. -- @@ -341,7 +358,7 @@ allLinks' => (Link -> a) -> Proxy api -> MkLink api a -allLinks' toA api = toLink toA api (Link mempty mempty) +allLinks' toA api = toLink toA api (Link mempty mempty mempty) ------------------------------------------------------------------------------- -- Generics @@ -563,6 +580,13 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where type MkLink (AuthProtect tag :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) +instance (HasLink sub, ToHttpApiData v) + => HasLink (Fragment v :> sub) where + type MkLink (Fragment v :> sub) a = v -> MkLink sub a + toLink toA _ l mv = + toLink toA (Proxy :: Proxy sub) $ + addFragment ((Just . Text.unpack . toQueryParam) mv) l + -- | Helper for implementing 'toLink' for combinators not affecting link -- structure. simpleToLink diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index 4445986a..2c1b02a3 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -71,6 +71,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = :<|> "summary" :> Summary "foo" :> GET :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) + :<|> "fragment" :> Fragment Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 845f5ee7..9d45e4a9 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -13,9 +13,9 @@ import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Servant.API +import Servant.Links import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) -import Servant.Links type TestApi = -- Capture and query params @@ -26,6 +26,9 @@ type TestApi = -- Flags :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent + -- Fragment + :<|> "say" :> Fragment String :> Get '[JSON] NoContent + -- All of the verbs :<|> "get" :> Get '[JSON] NoContent :<|> "put" :> Put '[JSON] NoContent @@ -76,6 +79,10 @@ spec = describe "Servant.Links" $ do apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" apiLink l1 False True `shouldBeLink` "balls?fast" + it "generates correct link for fragment" $ do + let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent) + apiLink l1 "something" `shouldBeLink` "say#something" + it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"