diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,41 @@ +0.7.1 +----- + +* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Allow to set the same header multiple times in responses. + +0.5 +--- + +* Add `WithNamedConfig` combinator. +* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators +* Fix safeLink, so Header is not in fact required. +* Add more instances for (:<|>) +* Use `http-api-data` instead of `Servant.Common.Text` +* Remove matrix params. +* Add PlainText String MimeRender and MimeUnrender instances. +* Add new `Verbs` combinator, and make all existing and new verb combinators +type synonyms of it. +* Add `BasicAuth` combinator to support Basic authentication +* Add generalized authentication support + +0.4.2 +----- +* Fix missing cases for `Patch` in `safeLink` + +0.4.1 +----- +* Allow whitespace after parsing JSON +* Stricter matching for `safeLink` for `Capture` + +0.4 +--- +* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body +* Multiple content-type/accept support for all the relevant combinators +* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box +* Type-safe link generation to API endpoints +* Support for the PATCH HTTP method +* Removed the home-made QuasiQuote for writing API types in a more human-friendly format until we come up with a better design for it +* Make most if not all of the haddock code examples run through doctest +* Some general code cleanup +* Add response headers diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,13 +1,13 @@ name: servant -version: 0.7 +version: 0.7.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE @@ -16,9 +16,11 @@ copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 +extra-source-files: + include/*.h + CHANGELOG.md source-repository head type: git location: http://github.com/haskell-servant/servant.git @@ -45,8 +47,9 @@ Servant.API.Verbs Servant.API.WithNamedContext Servant.Utils.Links + Servant.Utils.Enter build-depends: - base >= 4.7 && < 4.9 + base >= 4.7 && < 4.10 , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 @@ -56,6 +59,8 @@ , http-api-data >= 0.1 && < 0.3 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 + , mtl >= 2 && < 3 + , mmorph >= 1 , text >= 1 && < 2 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 @@ -83,12 +88,13 @@ , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -120,5 +126,5 @@ main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded include-dirs: include diff --git a/src/Servant/API/Header.hs b/src/Servant/API/Header.hs --- a/src/Servant/API/Header.hs +++ b/src/Servant/API/Header.hs @@ -3,7 +3,9 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Header where +module Servant.API.Header ( + Header(..), +) where import Data.ByteString (ByteString) import Data.Typeable (Typeable) @@ -25,5 +27,3 @@ -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs --- a/src/Servant/API/ResponseHeaders.hs +++ b/src/Servant/API/ResponseHeaders.hs @@ -68,8 +68,7 @@ instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h - , Contains h xs ~ 'False) +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) @@ -89,7 +88,7 @@ instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) ) => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest @@ -100,7 +99,7 @@ instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v ) => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs @@ -112,19 +111,14 @@ addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a)) + , new ~ (Headers '[Header h v] a) ) => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) - -type family Contains x xs where - Contains x ((Header x a) ': xs) = 'True - Contains x ((Header y a) ': xs) = Contains x xs - Contains x '[] = 'False -- $setup -- >>> import Servant.API diff --git a/src/Servant/API/Vault.hs b/src/Servant/API/Vault.hs --- a/src/Servant/API/Vault.hs +++ b/src/Servant/API/Vault.hs @@ -9,8 +9,8 @@ -- -- | Use 'Vault' in your API types to provide access to the 'Vault' -- of the request, which is a location shared by middlewares and applications --- to store arbitrary data. See 'Vault' for more details on how to actually --- use the vault in your handlers +-- to store arbitrary data. See +-- for more details on how to actually use the vault in your handlers -- -- Example: -- diff --git a/src/Servant/Utils/Enter.hs b/src/Servant/Utils/Enter.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Utils/Enter.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Utils.Enter where + +import qualified Control.Category as C +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#endif +import Control.Monad.Identity +import Control.Monad.Morph +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as LState +import qualified Control.Monad.State.Strict as SState +import qualified Control.Monad.Writer.Lazy as LWriter +import qualified Control.Monad.Writer.Strict as SWriter +import Data.Typeable +import Prelude () +import Prelude.Compat + +import Servant.API + +class Enter typ arg ret | typ arg -> ret, typ ret -> arg where + enter :: arg -> typ -> ret + +-- ** Servant combinators +instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 + , arg1 ~ arg2 + ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where + enter e (a :<|> b) = enter e a :<|> enter e b + +instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where + enter arg f a = enter arg (f a) + +-- ** Useful instances + +-- | A natural transformation from @m@ to @n@. Used to `enter` particular +-- datatypes. +newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable + +instance C.Category (:~>) where + id = Nat id + Nat f . Nat g = Nat (f . g) + +instance Enter (m a) (m :~> n) (n a) where + enter (Nat f) = f + +-- | Like `lift`. +liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m +liftNat = Nat Control.Monad.Morph.lift + +runReaderTNat :: r -> (ReaderT r m :~> m) +runReaderTNat a = Nat (`runReaderT` a) + +evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) +evalStateTLNat a = Nat (`LState.evalStateT` a) + +evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) +evalStateTSNat a = Nat (`SState.evalStateT` a) + +-- | Log the contents of `SWriter.WriterT` with the function provided as the +-- first argument, and return the value of the @WriterT@ computation +logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) +logWriterTSNat logger = Nat $ \x -> do + (a, w) <- SWriter.runWriterT x + liftIO $ logger w + return a + +-- | Like `logWriterTSNat`, but for strict @WriterT@. +logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) +logWriterTLNat logger = Nat $ \x -> do + (a, w) <- LWriter.runWriterT x + liftIO $ logger w + return a + +-- | Like @mmorph@'s `hoist`. +hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) +hoistNat (Nat n) = Nat $ hoist n + +-- | Like @mmorph@'s `embed`. +embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) +embedNat (Nat n) = Nat $ embed n + +-- | Like @mmorph@'s `squash`. +squashNat :: (Monad m, MMonad t) => t (t m) :~> t m +squashNat = Nat squash + +-- | Like @mmorph@'s `generalize`. +generalizeNat :: Applicative m => Identity :~> m +generalizeNat = Nat (pure . runIdentity) diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -72,14 +72,8 @@ -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) -- >>> safeLink api bad_link -- ... --- Could not deduce (Or --- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) --- (IsElem' --- ("hello" :> Delete '[JSON] ()) --- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) --- arising from a use of ‘safeLink’ --- In the expression: safeLink api bad_link --- In an equation for ‘it’: it = safeLink api bad_link +-- ...Could not deduce... +-- ... -- -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family @@ -116,6 +110,7 @@ import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) +import Servant.API.RemoteHost ( RemoteHost ) import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) @@ -290,6 +285,10 @@ instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + +instance HasLink sub => HasLink (RemoteHost :> sub) where + type MkLink (RemoteHost :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where @@ -28,7 +29,7 @@ import Network.URL (exportParams, importParams) import Test.Hspec import Test.QuickCheck -import Test.QuickCheck.Instances () +import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs --- a/test/Servant/Utils/LinksSpec.hs +++ b/test/Servant/Utils/LinksSpec.hs @@ -67,27 +67,27 @@ -- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy NotALink) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- sanity check