servant 0.18 → 0.18.1
raw patch · 6 files changed
+272/−12 lines, 6 filesdep +sop-coredep ~http-api-datanew-uploader
Dependencies added: sop-core
Dependency ranges changed: http-api-data
Files
- CHANGELOG.md +12/−0
- servant.cabal +12/−11
- src/Servant/API.hs +4/−0
- src/Servant/API/ContentTypes.hs +0/−1
- src/Servant/API/UVerb.hs +97/−0
- src/Servant/API/UVerb/Union.hs +147/−0
CHANGELOG.md view
@@ -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 ----
servant.cabal view
@@ -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
src/Servant/API.hs view
@@ -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
src/Servant/API/ContentTypes.hs view
@@ -419,7 +419,6 @@ mimeUnrender _ = Right . toStrict - -- $setup -- >>> :set -XFlexibleInstances -- >>> :set -XMultiParamTypeClasses
+ src/Servant/API/UVerb.hs view
@@ -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 <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> 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 :: [*])
+ src/Servant/API/UVerb/Union.hs view
@@ -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