diff --git a/servant.cabal b/servant.cabal index 7dc591e5..347ef56c 100644 --- a/servant.cabal +++ b/servant.cabal @@ -46,7 +46,7 @@ library build-depends: base >=4.7 && <5 , bytestring == 0.10.* - , http-media >= 0.4 && < 0.5 + , http-media >= 0.4 && < 0.6 , http-types == 0.8.* , text >= 1 && < 2 , template-haskell >= 2.7 && < 2.10 diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index f6895612..e0ae0e74 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -11,7 +11,6 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.API.ContentTypes where -import Control.Monad (join) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString) import Data.String.Conversions (cs) @@ -102,27 +101,25 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps ) => AllCTRender ctyps a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy ctyps - amrs = amr pctyps val - lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs - - + amrs = allMimeRender pctyps val + lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs -------------------------------------------------------------------------- -- * Unrender class Accept ctype => MimeUnrender ctype a where - fromByteString :: Proxy ctype -> ByteString -> Maybe a + fromByteString :: Proxy ctype -> ByteString -> Either String a class AllCTUnrender list a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body - -> Maybe a + -> Maybe (Either String a) instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) - where lkup = amu (Proxy :: Proxy ctyps) body + handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) + where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body -------------------------------------------------------------------------- -- * Utils (Internal) @@ -132,50 +129,42 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps -- Check that all elements of list are instances of MimeRender -------------------------------------------------------------------------- class AllMimeRender ls a where - amr :: Proxy ls - -> a -- value to serialize - -> [(M.MediaType, ByteString)] -- content-types/response pairs + allMimeRender :: Proxy ls + -> a -- value to serialize + -> [(M.MediaType, ByteString)] -- content-types/response pairs instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where - amr _ a = [(contentType pctyp, toByteString pctyp a)] + allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)] where pctyp = Proxy :: Proxy ctyp instance ( MimeRender ctyp a - , MimeRender ctyp' a -- at least two elems to avoid overlap - , AllMimeRender ctyps a + , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where - amr _ a = (contentType pctyp, toByteString pctyp a) - :(contentType pctyp', toByteString pctyp' a) - :(amr pctyps a) + allMimeRender _ a = (contentType pctyp, toByteString pctyp a) + :(allMimeRender pctyps a) where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' + pctyps = Proxy :: Proxy (ctyp' ': ctyps) instance AllMimeRender '[] a where - amr _ _ = [] + allMimeRender _ _ = [] -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- class AllMimeUnrender ls a where - amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)] + allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)] -instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where - amu _ val = [(contentType pctyp, fromByteString pctyp val)] - where pctyp = Proxy :: Proxy ctyp +instance AllMimeUnrender '[] a where + allMimeUnrender _ _ = [] instance ( MimeUnrender ctyp a - , MimeUnrender ctyp' a , AllMimeUnrender ctyps a - ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where - amu _ val = (contentType pctyp, fromByteString pctyp val) - :(contentType pctyp', fromByteString pctyp' val) - :(amu pctyps val) + ) => AllMimeUnrender (ctyp ': ctyps) a where + allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val) + :(allMimeUnrender pctyps val) where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' type family IsNonEmpty (ls::[*]) :: Constraint where - IsNonEmpty '[] = 'False ~ 'True - IsNonEmpty x = () + IsNonEmpty (x ': xs) = () diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index d0cb8311..8f04fdb5 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -10,5 +10,5 @@ import Data.Typeable ( Typeable ) -- Example: -- -- > type MyApi = "books" :> Get '[JSON] [Book] -data Get (cts::[*]) a +data Get (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/Patch.hs b/src/Servant/API/Patch.hs index d2643d5b..b2584f96 100644 --- a/src/Servant/API/Patch.hs +++ b/src/Servant/API/Patch.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} module Servant.API.Patch where import Data.Typeable ( Typeable ) @@ -11,9 +13,9 @@ import Data.Typeable ( Typeable ) -- -- Example: -- --- > -- POST /books +-- > -- PATCH /books -- > -- with a JSON encoded Book as the request body -- > -- returning the just-created Book --- > type MyApi = "books" :> ReqBody Book :> Post Book -data Patch a +-- > type MyApi = "books" :> ReqBody Book :> Patch '[JSON] Book +data Patch (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index c1a64b8d..4ba32d71 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -15,5 +15,5 @@ import Data.Typeable ( Typeable ) -- > -- with a JSON encoded Book as the request body -- > -- returning the just-created Book -- > type MyApi = "books" :> ReqBody Book :> Post '[JSON] Book -data Post (cts::[*]) a +data Post (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index de14c597..3166998d 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -13,5 +13,5 @@ import Data.Typeable ( Typeable ) -- > -- PUT /books/:isbn -- > -- with a Book as request body, returning the updated Book -- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put '[JSON] Book -data Put (cts::[*]) a +data Put (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs index e7df0b7b..ecf5b4d9 100644 --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -8,4 +8,4 @@ module Servant.API.ReqBody where -- -- > -- POST /books -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post Book -data ReqBody (ls::[*]) a +data ReqBody (contentTypes::[*]) a diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs index 3ab9ae7d..22275afb 100644 --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -180,7 +180,6 @@ type family IsSubList a b :: Constraint where IsSubList '[x] (x ': xs) = () IsSubList '[x] (y ': ys) = IsSubList '[x] ys IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y - IsSubList a b = 'True ~ 'False -- Phantom types for Param data Matrix