servant 0.18.1 → 0.18.2
raw patch · 10 files changed
+168/−41 lines, 10 filesdep ~hspec
Dependency ranges changed: hspec
Files
- CHANGELOG.md +8/−0
- servant.cabal +2/−1
- src/Servant/API.hs +12/−9
- src/Servant/API/Fragment.hs +25/−0
- src/Servant/API/Modifiers.hs +0/−2
- src/Servant/API/TypeLevel.hs +59/−9
- src/Servant/API/UVerb.hs +23/−13
- src/Servant/Links.hs +30/−6
- src/Servant/Test/ComprehensiveAPI.hs +1/−0
- test/Servant/LinksSpec.hs +8/−1
CHANGELOG.md view
@@ -1,5 +1,13 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18.2+------++### Significant changes++- Introduce `Fragment` combinator.+- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`.+ 0.18.1 ------
servant.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-version: 0.18.1+version: 0.18.2 synopsis: A family of combinators for defining webservices APIs category: Servant, Web@@ -40,6 +40,7 @@ Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth+ Servant.API.Fragment Servant.API.Generic Servant.API.Header Servant.API.HttpVersion
src/Servant/API.hs view
@@ -19,6 +19,8 @@ -- | 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 @@ (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 @@ 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
+ src/Servant/API/Fragment.hs view
@@ -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 }
src/Servant/API/Modifiers.hs view
@@ -131,8 +131,6 @@ (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))
src/Servant/API/TypeLevel.hs view
@@ -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 @@ -- ** Logic Or, And,+ -- ** Fragment+ FragmentUnique,+ AtLeastOneFragment ) where @@ -50,6 +57,7 @@ (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll)+import Servant.API.Fragment import Servant.API.Header (Header) import Servant.API.QueryParam@@ -60,6 +68,8 @@ (type (:>)) import Servant.API.Verbs (Verb)+import Servant.API.UVerb+ (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -128,6 +138,7 @@ 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,13 +252,51 @@ 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 -- -- The doctests in this module are run with following preamble: -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs+-- >>> :set -XTypeSynonymInstances -XFlexibleInstances -- >>> import Data.Proxy -- >>> import Data.Type.Equality -- >>> import Servant.API@@ -255,4 +304,5 @@ -- >>> 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
src/Servant/API/UVerb.hs view
@@ -4,14 +4,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | An alternative to 'Verb' for end-points that respond with a resource value of any of an -- open union of types, and specific status codes for each type in this union. (`UVerb` is@@ -34,12 +33,10 @@ ) where -import Data.Aeson (FromJSON, ToJSON) import Data.Proxy (Proxy (Proxy))-import qualified GHC.Generics as GHC import GHC.TypeLits (Nat) import Network.HTTP.Types (Status, StdMethod)-import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)+import Servant.API.ContentTypes (NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender)) import Servant.API.Status (KnownStatus, statusVal) import Servant.API.UVerb.Union @@ -49,9 +46,6 @@ statusOf :: forall a proxy. HasStatus a => proxy a -> Status statusOf = const (statusVal (Proxy :: Proxy (StatusOf a))) -instance KnownStatus n => HasStatus (WithStatus n a) where- type StatusOf (WithStatus n a) = n- -- | If an API can respond with 'NoContent' we assume that this will happen -- with the status code 204 No Content. If this needs to be overridden, -- 'WithStatus' can be used.@@ -70,12 +64,10 @@ type Statuses (a ': as) = StatusOf a ': Statuses as statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as) +-- | A simple newtype wrapper that pairs a type with its status code. It+-- implements all the content types that Servant ships with by default. newtype WithStatus (k :: Nat) a = WithStatus a- deriving (Eq, Show, GHC.Generic)--instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)--instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)+ deriving (Eq, Show) instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a@@ -83,6 +75,24 @@ instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input++-- | an instance of this typeclass assigns a HTTP status code to a return type+--+-- Example:+--+-- @+-- data NotFoundError = NotFoundError String+--+-- instance HasStatus NotFoundError where+-- type StatusOf NotFoundError = 404+-- @+--+-- You can also use the convience newtype wrapper 'WithStatus' if you want to+-- avoid writing a 'HasStatus' instance manually. It also has the benefit of+-- showing the status code in the type; which might aid in readability.+instance KnownStatus n => HasStatus (WithStatus n a) where+ type StatusOf (WithStatus n a) = n+ -- | A variant of 'Verb' that can have any of a number of response values and status codes. --
src/Servant/Links.hs view
@@ -120,6 +120,7 @@ , Param (..) , linkSegments , linkQueryParams+ , linkFragment ) where import Data.List@@ -152,6 +153,8 @@ (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 @@ 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 @@ 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 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 @@ -- >>> 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 @@ -- 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 @@ 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 @@ -> 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 @@ => (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@@ -562,6 +579,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.
src/Servant/Test/ComprehensiveAPI.hs view
@@ -71,6 +71,7 @@ :<|> "summary" :> Summary "foo" :> GET :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)+ :<|> "fragment" :> Fragment Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
test/Servant/LinksSpec.hs view
@@ -13,9 +13,9 @@ (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 @@ -- 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@@ -75,6 +78,10 @@ :> QueryFlag "fast" :> Delete '[JSON] NoContent) 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"