diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + 0.18 ---- diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant -version: 0.18 +version: 0.18.1 synopsis: A family of combinators for defining webservices APIs category: Servant, Web @@ -20,14 +20,8 @@ copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.3 - || ==8.10.1 - , GHCJS == 8.4 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 + , GHCJS == 8.4 extra-source-files: CHANGELOG.md @@ -60,6 +54,8 @@ Servant.API.Stream Servant.API.Sub Servant.API.TypeLevel + Servant.API.UVerb + Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext @@ -84,6 +80,7 @@ base >= 4.9 && < 4.15 , bytestring >= 0.10.8.1 && < 0.11 , mtl >= 2.2.2 && < 2.3 + , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 @@ -91,7 +88,7 @@ -- We depend (heavily) on the API of these packages: -- i.e. re-export, or allow using without direct dependency build-depends: - http-api-data >= 0.4.1 && < 0.4.2 + http-api-data >= 0.4.1 && < 0.4.3 , singleton-bool >= 0.1.4 && < 0.1.6 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. @@ -114,11 +111,13 @@ hs-source-dirs: src default-language: Haskell2010 - other-extensions: CPP + other-extensions: AllowAmbiguousTypes + , CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , DeriveGeneric + , ExplicitNamespaces , FlexibleContexts , FlexibleInstances , FunctionalDependencies @@ -127,11 +126,13 @@ , MultiParamTypeClasses , OverloadedStrings , PolyKinds + , RankNTypes , ScopedTypeVariables , TupleSections , TypeFamilies , TypeOperators , UndecidableInstances + ghc-options: -Wall -Wno-redundant-constraints test-suite spec diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -32,6 +32,7 @@ -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + module Servant.API.UVerb, -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, @@ -132,6 +133,9 @@ PutCreated, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), StdMethod (..), Verb, NoContentVerb) +import Servant.API.UVerb + (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses, + WithStatus (..), IsMember, Unique, inject) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Links diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -419,7 +419,6 @@ mimeUnrender _ = Right . toStrict - -- $setup -- >>> :set -XFlexibleInstances -- >>> :set -XMultiParamTypeClasses diff --git a/src/Servant/API/UVerb.hs b/src/Servant/API/UVerb.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/UVerb.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | 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 +-- short for `UnionVerb`) +-- +-- This can be used for returning (rather than throwing) exceptions in a server as in, say +-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or +-- 201 created with a different body type, depending on the circumstances. (All of this can +-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in +-- the API types without something like `UVerb`.) +-- +-- See for a working example. +module Servant.API.UVerb + ( UVerb, + HasStatus (StatusOf), + statusOf, + HasStatuses (Statuses, statuses), + WithStatus (..), + module Servant.API.UVerb.Union, + ) +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.Status (KnownStatus, statusVal) +import Servant.API.UVerb.Union + +class KnownStatus (StatusOf a) => HasStatus (a :: *) where + type StatusOf (a :: *) :: Nat + +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. +instance HasStatus NoContent where + type StatusOf NoContent = 204 + +class HasStatuses (as :: [*]) where + type Statuses (as :: [*]) :: [Nat] + statuses :: Proxy as -> [Status] + +instance HasStatuses '[] where + type Statuses '[] = '[] + statuses _ = [] + +instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where + type Statuses (a ': as) = StatusOf a ': Statuses as + statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as) + +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) + +instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where + mimeUnrender contentTypeProxy input = + WithStatus <$> mimeUnrender contentTypeProxy input + +-- | A variant of 'Verb' that can have any of a number of response values and status codes. +-- +-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write +-- instances for 'HasServer' etc. for the latter, getting them for the former for free. +-- Something like: +-- +-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@ +-- +-- Backwards compatibility is tricky, though: this type alias would mean people would have to +-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten. +data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*]) diff --git a/src/Servant/API/UVerb/Union.hs b/src/Servant/API/UVerb/Union.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/UVerb/Union.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- + +Copyright Dennis Gosnell (c) 2017-2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-} + +-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by +-- [world-piece](https://github.com/cdepillabout/world-peace). +module Servant.API.UVerb.Union +( IsMember +, Unique +, Union +, inject +, eject +, foldMapUnion +, matchUnion +) +where + +import Data.Proxy (Proxy) +import Data.SOP.BasicFunctors (I, unI) +import Data.SOP.Constraint +import Data.SOP.NS +import Data.Type.Bool (If) +import Data.Type.Equality (type (==)) +import GHC.TypeLits + +type Union = NS I + +-- | Convenience function to apply a function to an unknown union element using a type class. +-- All elements of the union must have instances in the type class, and the function is +-- applied unconditionally. +-- +-- See also: 'matchUnion'. +foldMapUnion :: + forall (c :: * -> Constraint) (a :: *) (as :: [*]). + All c as => + Proxy c -> + (forall x. c x => x -> a) -> + Union as -> + a +foldMapUnion proxy go = cfoldMap_NS proxy (go . unI) + +-- | Convenience function to extract a union element using 'cast', ie. return the value if the +-- selected type happens to be the actual type of the union in this value, or 'Nothing' +-- otherwise. +-- +-- See also: 'foldMapUnion'. +matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a +matchUnion = fmap unI . eject + +-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop + +-- (this could to go sop-core, except it's probably too specialized to the servant use-case.) + +type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as) + +class UElem x xs where + inject :: f x -> NS f xs + eject :: NS f xs -> Maybe (f x) + +instance {-# OVERLAPPING #-} UElem x (x ': xs) where + inject = Z + eject (Z x) = Just x + eject _ = Nothing + +instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where + inject = S . inject + eject (Z _) = Nothing + eject (S ns) = eject ns + +-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the +-- list, or if there is a duplicate in the list. +type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where + CheckElemIsMember a as = + If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) + +type NoElementError (r :: k) (rs :: [k]) = + 'Text "Expected one of:" + ':$$: 'Text " " ':<>: 'ShowType rs + ':$$: 'Text "But got:" + ':$$: 'Text " " ':<>: 'ShowType r + +type DuplicateElementError (rs :: [k]) = + 'Text "Duplicate element in list:" + ':$$: 'Text " " ':<>: 'ShowType rs + +type family Elem (x :: k) (xs :: [k]) :: Bool where + Elem _ '[] = 'False + Elem x (x' ': xs) = + If (x == x') 'True (Elem x xs) + +type family Unique xs :: Constraint where + Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs)) + +type family Nubbed xs :: Bool where + Nubbed '[] = 'True + Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs) + +_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False + , Nubbed '[Int, Int, Bool] ~ 'False + , Nubbed '[Int, Bool] ~ 'True + ) + => a) -> a +_testNubbed = id