diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..a6d6a443 --- /dev/null +++ b/default.nix @@ -0,0 +1,12 @@ +{ pkgs ? import { config.allowUnfree = true; } +, src ? builtins.filterSource (path: type: + type != "unknown" && + baseNameOf path != ".git" && + baseNameOf path != "result" && + baseNameOf path != "dist") ./. +}: +pkgs.haskellPackages.buildLocalCabalWithArgs { + name = "servant"; + inherit src; + args = {}; +} diff --git a/servant.cabal b/servant.cabal index 84703f50..19092f45 100644 --- a/servant.cabal +++ b/servant.cabal @@ -28,6 +28,7 @@ library Servant.API Servant.API.Alternative Servant.API.Capture + Servant.API.ContentTypes Servant.API.Delete Servant.API.Get Servant.API.Header @@ -40,17 +41,39 @@ library Servant.API.ReqBody Servant.API.Sub Servant.Common.Text - Servant.QQ Servant.Utils.Links build-depends: base >=4.7 && <5 - , text >= 1 - , template-haskell + , aeson >= 0.7 + , bytestring == 0.10.* + , http-media >= 0.4 && < 0.6 + , http-types == 0.8.* + , text >= 1 && < 2 + , template-haskell >= 2.7 && < 2.10 , parsec >= 3.1 - , string-conversions >= 0.3 + , string-conversions >= 0.3 && < 0.4 , network-uri >= 2.6 hs-source-dirs: src default-language: Haskell2010 + other-extensions: ConstraintKinds + , DataKinds + , DeriveDataTypeable + , FlexibleInstances + , FunctionalDependencies + , GADTs + , KindSignatures + , MultiParamTypeClasses + , OverlappingInstances + , OverloadedStrings + , PolyKinds + , QuasiQuotes + , RecordWildCards + , ScopedTypeVariables + , TemplateHaskell + , TypeFamilies + , TypeOperators + , TypeSynonymInstances + , UndecidableInstances ghc-options: -Wall test-suite spec @@ -62,6 +85,8 @@ test-suite spec main-is: Spec.hs build-depends: base == 4.* + , aeson + , bytestring , hspec == 2.* , QuickCheck , parsec diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 83f7f77a..f5969df3 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -30,19 +30,22 @@ module Servant.API ( -- | PATCH requests module Servant.API.Patch, + -- * Content Types + module Servant.API.ContentTypes, + -- * Untyped endpoints -- | Plugging in a wai 'Network.Wai.Application', serving directories module Servant.API.Raw, -- * Utilities - -- | QuasiQuotes for endpoints - module Servant.QQ, -- | Type-safe internal URIs module Servant.Utils.Links, ) where import Servant.API.Alternative ( (:<|>)(..) ) import Servant.API.Capture ( Capture ) +import Servant.API.ContentTypes ( JSON , PlainText, OctetStream + , MimeRender(..) , MimeUnrender(..)) import Servant.API.Delete ( Delete ) import Servant.API.Get ( Get ) import Servant.API.Header ( Header ) @@ -54,5 +57,4 @@ import Servant.API.MatrixParam ( MatrixFlag, MatrixParams, MatrixParam ) import Servant.API.Raw ( Raw ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.Sub ( (:>)(..) ) -import Servant.QQ ( sitemap ) import Servant.Utils.Links ( safeLink, URI(..), IsElem, IsElem', HasLink(..) ) diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs new file mode 100644 index 00000000..249756c3 --- /dev/null +++ b/src/Servant/API/ContentTypes.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.API.ContentTypes where + +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON, eitherDecode, + encode) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) +import Data.String.Conversions (cs) +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL +import qualified Data.Text as TextS +import qualified Data.Text.Encoding as TextS +import Data.Typeable +import GHC.Exts (Constraint) +import qualified Network.HTTP.Media as M + +-- * Provided content types +data JSON deriving Typeable +data PlainText deriving Typeable +data OctetStream deriving Typeable + +-- * Accept class + +-- | Instances of 'Accept' represent mimetypes. They are used for matching +-- against the @Accept@ HTTP header of the request, and for setting the +-- @Content-Type@ header of the response +-- +-- Example: +-- +-- > instance Accept HTML where +-- > contentType _ = "text" // "html" +-- +class Accept ctype where + contentType :: Proxy ctype -> M.MediaType + +-- | @application/json@ +instance Accept JSON where + contentType _ = "application" M.// "json" + +-- | @text/plain;charset=utf-8@ +instance Accept PlainText where + contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") + +-- | @application/octet-stream@ +instance Accept OctetStream where + contentType _ = "application" M.// "octet-stream" + +newtype AcceptHeader = AcceptHeader BS.ByteString + deriving (Eq, Show) + +-- * Render (serializing) + +-- | Instantiate this class to register a way of serializing a type based +-- on the @Accept@ header. +-- +-- Example: +-- +-- > data MyContentType +-- > +-- > instance Accept MyContentType where +-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") +-- > +-- > instance Show a => MimeRender MyContentType where +-- > toByteString _ val = pack ("This is MINE! " ++ show val) +-- > +-- > type MyAPI = "path" :> Get '[MyContentType] Int +-- +class Accept ctype => MimeRender ctype a where + toByteString :: Proxy ctype -> a -> ByteString + +class AllCTRender list a where + -- If the Accept header can be matched, returns (Just) a tuple of the + -- Content-Type and response (serialization of @a@ into the appropriate + -- mimetype). + handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) + +instance ( AllMimeRender ctyps a, IsNonEmpty ctyps + ) => AllCTRender ctyps a where + handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept + where pctyps = Proxy :: Proxy ctyps + amrs = allMimeRender pctyps val + lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs + + +-------------------------------------------------------------------------- +-- * Unrender + +-- | Instantiate this class to register a way of deserializing a type based +-- on the request's @Content-Type@ header. +-- +-- > data MyContentType = MyContentType String +-- > +-- > instance Accept MyContentType where +-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") +-- > +-- > instance Show a => MimeUnrender MyContentType where +-- > fromByteString _ bs = MyContentType $ unpack bs +-- > +-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int +-- +class Accept ctype => MimeUnrender ctype a where + fromByteString :: Proxy ctype -> ByteString -> Either String a + +class (IsNonEmpty list) => AllCTUnrender list a where + handleCTypeH :: Proxy list + -> ByteString -- Content-Type header + -> ByteString -- Request body + -> Maybe (Either String a) + +instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps + ) => AllCTUnrender ctyps a where + handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) + where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body + +-------------------------------------------------------------------------- +-- * Utils (Internal) + + +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeRender +-------------------------------------------------------------------------- +class AllMimeRender ls a where + allMimeRender :: Proxy ls + -> a -- value to serialize + -> [(M.MediaType, ByteString)] -- content-types/response pairs + +instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where + allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)] + where pctyp = Proxy :: Proxy ctyp + +instance ( MimeRender ctyp a + , AllMimeRender (ctyp' ': ctyps) a + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where + allMimeRender _ a = (contentType pctyp, toByteString pctyp a) + :(allMimeRender pctyps a) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy (ctyp' ': ctyps) + + +instance AllMimeRender '[] a where + allMimeRender _ _ = [] + +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeUnrender +-------------------------------------------------------------------------- +class AllMimeUnrender ls a where + allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)] + +instance AllMimeUnrender '[] a where + allMimeUnrender _ _ = [] + +instance ( MimeUnrender ctyp a + , AllMimeUnrender ctyps a + ) => AllMimeUnrender (ctyp ': ctyps) a where + allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val) + :(allMimeUnrender pctyps val) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + +type family IsNonEmpty (ls::[*]) :: Constraint where + IsNonEmpty (x ': xs) = () + + +-------------------------------------------------------------------------- +-- * MimeRender Instances + +-- | `encode` +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +-- | `TextL.encodeUtf8` +instance MimeRender PlainText TextL.Text where + toByteString _ = TextL.encodeUtf8 + +-- | `fromStrict . TextS.encodeUtf8` +instance MimeRender PlainText TextS.Text where + toByteString _ = fromStrict . TextS.encodeUtf8 + +-- | `id` +instance MimeRender OctetStream ByteString where + toByteString _ = id + +-- | `toStrict` +instance MimeRender OctetStream BS.ByteString where + toByteString _ = fromStrict + + +-------------------------------------------------------------------------- +-- * MimeUnrender Instances + +-- | `eitherDecode` +instance FromJSON a => MimeUnrender JSON a where + fromByteString _ = eitherDecode + +-- | `left show . TextL.decodeUtf8'` +instance MimeUnrender PlainText TextL.Text where + fromByteString _ = left show . TextL.decodeUtf8' + +-- | `left show . TextS.decodeUtf8' . toStrict` +instance MimeUnrender PlainText TextS.Text where + fromByteString _ = left show . TextS.decodeUtf8' . toStrict + +-- | `Right . id` +instance MimeUnrender OctetStream ByteString where + fromByteString _ = Right . id + +-- | `Right . toStrict` +instance MimeUnrender OctetStream BS.ByteString where + fromByteString _ = Right . toStrict diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index 37cb5bf4..8f04fdb5 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} module Servant.API.Get where import Data.Typeable ( Typeable ) @@ -7,6 +9,6 @@ import Data.Typeable ( Typeable ) -- -- Example: -- --- > type MyApi = "books" :> Get [Book] -data Get a +-- > type MyApi = "books" :> Get '[JSON] [Book] +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 fa57f261..4ba32d71 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} module Servant.API.Post where import Data.Typeable ( Typeable ) @@ -12,6 +14,6 @@ import Data.Typeable ( Typeable ) -- > -- POST /books -- > -- with a JSON encoded Book as the request body -- > -- returning the just-created Book --- > type MyApi = "books" :> ReqBody Book :> Post Book -data Post a +-- > type MyApi = "books" :> ReqBody Book :> Post '[JSON] Book +data Post (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 201cce8d..3166998d 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} module Servant.API.Put where import Data.Typeable ( Typeable ) @@ -10,6 +12,6 @@ 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 Book -data Put a +-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put '[JSON] Book +data Put (contentTypes::[*]) a deriving Typeable diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index fddfd461..eeaec597 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.Raw where +import Data.Typeable (Typeable) -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with @@ -9,4 +11,4 @@ module Servant.API.Raw where -- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve -- static files stored in a particular directory on your filesystem, or to serve -- your API's documentation with 'Servant.Utils.StaticFiles.serveDocumentation'. -data Raw +data Raw deriving Typeable diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs index 550275aa..ecf5b4d9 100644 --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} module Servant.API.ReqBody where @@ -6,5 +7,5 @@ module Servant.API.ReqBody where -- Example: -- -- > -- POST /books --- > type MyApi = "books" :> ReqBody Book :> Post Book -data ReqBody a +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post Book +data ReqBody (contentTypes::[*]) a diff --git a/src/Servant/QQ.hs b/src/Servant/QQ.hs deleted file mode 100644 index 6c09e2bf..00000000 --- a/src/Servant/QQ.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} --- | QuasiQuoting utilities for API types. --- --- 'sitemap' allows you to write your type in a very natural way: --- --- @ --- [sitemap| --- PUT hello String -> () --- POST hello/p:Int String -> () --- GET hello/?name:String Int --- |] --- @ --- --- Will generate: --- --- @ --- "hello" :> ReqBody String :> Put () --- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post () --- :\<|> "hello" :> QueryParam "name" String :> Get Int --- @ --- --- Note the @/@ before a @QueryParam@! -module Servant.QQ (sitemap) where - -import Control.Monad ( void ) -import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) -import Language.Haskell.TH - ( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) ) -import Text.ParserCombinators.Parsec - ( try, - Parser, - manyTill, - endBy, - sepBy1, - optional, - optionMaybe, - string, - anyChar, - char, - spaces, - noneOf, - parse, - skipMany, - many, - lookAhead, - (<|>), - () ) -import Servant.API.Capture ( Capture ) -import Servant.API.Get ( Get ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.Delete ( Delete ) -import Servant.API.QueryParam ( QueryParam ) -import Servant.API.MatrixParam ( MatrixParam ) -import Servant.API.ReqBody ( ReqBody ) -import Servant.API.Sub ( (:>) ) -import Servant.API.Alternative ( (:<|>) ) - --- | Finally-tagless encoding for our DSL. --- Keeping 'repr'' and 'repr' distinct when writing functions with an --- @ExpSYM@ context ensures certain invariants (for instance, that there is --- only one of 'get', 'post', 'put', and 'delete' in a value), but --- sometimes requires a little more work. -class ExpSYM repr' repr | repr -> repr', repr' -> repr where - lit :: String -> repr' -> repr - capture :: String -> String -> repr -> repr - reqBody :: String -> repr -> repr - queryParam :: String -> String -> repr -> repr - matrixParam :: String -> String -> repr -> repr - conj :: repr' -> repr -> repr - get :: String -> repr - post :: String -> repr - put :: String -> repr - delete :: String -> repr - - -infixr 6 >: - -(>:) :: Type -> Type -> Type -(>:) = conj - - -instance ExpSYM Type Type where - lit name r = LitT (StrTyLit name) >: r - capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name))) - (ConT $ mkName typ) >: r - reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r - queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name))) - (ConT $ mkName typ) >: r - matrixParam name typ r = AppT (AppT (ConT ''MatrixParam) (LitT (StrTyLit name))) - (ConT $ mkName typ) >: r - conj x = AppT (AppT (ConT ''(:>)) x) - get typ = AppT (ConT ''Get) (ConT $ mkName typ) - post typ = AppT (ConT ''Post) (ConT $ mkName typ) - put typ = AppT (ConT ''Put) (ConT $ mkName typ) - delete "()" = ConT ''Delete - delete _ = error "Delete does not return a request body" - -parseMethod :: ExpSYM repr' repr => Parser (String -> repr) -parseMethod = try (string "GET" >> return get) - <|> try (string "POST" >> return post) - <|> try (string "PUT" >> return put) - <|> try (string "DELETE" >> return delete) - -parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr) -parseUrlSegment = try parseCapture - <|> try parseQueryParam - <|> try parseLit - where - parseCapture = do - cname <- many (noneOf " ?/:;") - char ':' - ctyp <- many (noneOf " ?/:;") - mx <- many parseMatrixParam - return $ capture cname ctyp . foldr (.) id mx - parseQueryParam = do - char '?' - cname <- many (noneOf " ?/:;") - char ':' - ctyp <- many (noneOf " ?/:;") - return $ queryParam cname ctyp - parseLit = do - lt <- many (noneOf " ?/:;") - mx <- many parseMatrixParam - return $ lit lt . foldr (.) id mx - parseMatrixParam = do - char ';' - cname <- many (noneOf " ?/:;") - char ':' - ctyp <- many (noneOf " ?/:;") - return $ matrixParam cname ctyp - -parseUrl :: ExpSYM repr repr => Parser (repr -> repr) -parseUrl = do - optional $ char '/' - url <- parseUrlSegment `sepBy1` char '/' - return $ foldr1 (.) url - -data Typ = Val String - | ReqArgVal String String - -parseTyp :: Parser Typ -parseTyp = do - f <- many (noneOf "-{\n\r") - spaces - s <- optionMaybe (try parseRet) - try $ optional inlineComment - try $ optional blockComment - case s of - Nothing -> return $ Val (stripTr f) - Just s' -> return $ ReqArgVal (stripTr f) (stripTr s') - where - parseRet :: Parser String - parseRet = do - string "->" - spaces - many (noneOf "-{\n\r") - stripTr = reverse . dropWhile (== ' ') . reverse - - -parseEntry :: ExpSYM repr repr => Parser repr -parseEntry = do - met <- parseMethod - spaces - url <- parseUrl - spaces - typ <- parseTyp - case typ of - Val s -> return $ url (met s) - ReqArgVal i o -> return $ url $ reqBody i (met o) - -blockComment :: Parser () -blockComment = do - string "{-" - manyTill anyChar (try $ string "-}") - return () - -inlineComment :: Parser () -inlineComment = do - string "--" - manyTill anyChar (try $ lookAhead eol) - return () - -eol :: Parser String -eol = try (string "\n\r") - <|> try (string "\r\n") - <|> string "\n" - <|> string "\r" - "end of line" - -eols :: Parser () -eols = skipMany $ void eol <|> blockComment <|> inlineComment - -parseAll :: Parser Type -parseAll = do - eols - entries <- parseEntry `endBy` eols - return $ foldr1 union entries - where union :: Type -> Type -> Type - union a = AppT (AppT (ConT ''(:<|>)) a) - --- | The sitemap QuasiQuoter. --- --- * @.../:/...@ becomes a capture --- * @.../?:@ becomes a query parameter --- * @ ... @ becomes a method returning @@ --- * @ ... -> @ becomes a method with request --- body of @@ and returning @@ --- --- Comments are allowed, and have the standard Haskell format --- --- * @--@ for inline --- * @{- ... -}@ for block --- -sitemap :: QuasiQuoter -sitemap = QuasiQuoter { quoteExp = undefined - , quotePat = undefined - , quoteType = \x -> case parse parseAll "" x of - Left err -> error $ show err - Right st -> return st - , quoteDec = undefined - } diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs index d49fd599..22275afb 100644 --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -2,10 +2,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -- | Type safe generation of internal links. @@ -19,7 +20,7 @@ -- >>> -- >>> -- >>> --- >>> type Hello = "hello" :> Get Int +-- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete -- >>> type API = Hello :<|> Bye -- >>> let api = Proxy :: Proxy API @@ -39,7 +40,7 @@ -- function that accepts that input and generates a link. This is best shown -- with an example. Here, a link is generated with no parameters: -- --- >>> let hello = Proxy :: Proxy ("hello" :> Get Int) +-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) -- >>> print (safeLink api hello :: URI) -- hello -- @@ -73,7 +74,7 @@ -- -- :64:1: -- Could not deduce (Or --- (IsElem' Delete (Get Int)) +-- (IsElem' Delete (Get '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete) -- ("bye" :> (QueryParam "name" String :> Delete)))) @@ -122,11 +123,23 @@ import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) ) +-- | A safe link datatype. +-- The only way of constructing a 'Link' is using 'safeLink', which means any +-- 'Link' is guaranteed to be part of the mentioned API. +data Link = Link + { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] + , _queryParams :: [Param Query] + } deriving Show + -- | If either a or b produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where Or () b = () Or a () = () +-- | If both a or b produce an empty constraint, produce an empty constraint. +type family And (a :: Constraint) (b :: Constraint) :: Constraint where + And () () = () + -- | You may use this type family to tell the type checker that your custom type -- may be skipped as part of a link. This is useful for things like -- 'QueryParam' that are optional in a URI and do not affect them if they are @@ -147,24 +160,26 @@ type family IsElem endpoint api :: Constraint where IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) IsElem (e :> sa) (e :> sb) = IsElem sa sb IsElem sa (Header x :> sb) = IsElem sa sb - IsElem sa (ReqBody x :> sb) = IsElem sa sb + IsElem sa (ReqBody y x :> sb) = IsElem sa sb + IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb 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 (MatrixParam x y :> sb) = IsElem sa sb IsElem sa (MatrixParams x y :> sb) = IsElem sa sb IsElem sa (MatrixFlag x :> sb) = IsElem sa sb + IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' + IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' + IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a --- | A safe link datatype. --- The only way of constructing a 'Link' is using 'safeLink', which means any --- 'Link' is guaranteed to be part of the mentioned API. -data Link = Link - { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] - , _queryParams :: [Param Query] - } deriving Show +type family IsSubList a b :: Constraint where + IsSubList '[] b = () + IsSubList '[x] (x ': xs) = () + IsSubList '[x] (y ': ys) = IsSubList '[x] ys + IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y -- Phantom types for Param data Matrix @@ -317,16 +332,16 @@ instance (ToText v, HasLink sub) addSegment (escape . unpack $ toText v) l -- Verb (terminal) instances -instance HasLink (Get r) where - type MkLink (Get r) = URI +instance HasLink (Get y r) where + type MkLink (Get y r) = URI toLink _ = linkURI -instance HasLink (Post r) where - type MkLink (Post r) = URI +instance HasLink (Post y r) where + type MkLink (Post y r) = URI toLink _ = linkURI -instance HasLink (Put r) where - type MkLink (Put r) = URI +instance HasLink (Put y r) where + type MkLink (Put y r) = URI toLink _ = linkURI instance HasLink Delete where diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs new file mode 100644 index 00000000..d02203e6 --- /dev/null +++ b/test/Servant/API/ContentTypesSpec.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.API.ContentTypesSpec where + +import Control.Applicative +import Data.Aeson +import Data.Function (on) +import Data.Proxy + +import Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as BSL +import Data.List (maximumBy) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.String (IsString (..)) +import Data.String.Conversions (cs) +import qualified Data.Text as TextS +import qualified Data.Text.Lazy as TextL +import GHC.Generics +import Test.Hspec +import Test.QuickCheck + +import Servant.API.ContentTypes + +spec :: Spec +spec = describe "Servant.API.ContentTypes" $ do + + describe "The JSON Content-Type type" $ do + + it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do + let p = Proxy :: Proxy JSON + property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int]) + + it "has fromByteString reverse toByteString for valid top-level json " $ do + let p = Proxy :: Proxy JSON + property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData) + + describe "The PlainText Content-Type type" $ do + + it "has fromByteString reverse toByteString (lazy Text)" $ do + let p = Proxy :: Proxy PlainText + property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text) + + it "has fromByteString reverse toByteString (strict Text)" $ do + let p = Proxy :: Proxy PlainText + property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text) + + describe "The OctetStream Content-Type type" $ do + + it "is id (Lazy ByteString)" $ do + let p = Proxy :: Proxy OctetStream + property $ \x -> toByteString p x == (x :: BSL.ByteString) + && fromByteString p x == Right x + + it "is fromStrict/toStrict (Strict ByteString)" $ do + let p = Proxy :: Proxy OctetStream + property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString) + && fromByteString p (BSL.fromStrict x) == Right x + + describe "handleAcceptH" $ do + + it "returns Nothing if the 'Accept' header doesn't match" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "text/plain" (3 :: Int) + `shouldSatisfy` isNothing + + it "returns Just if the 'Accept' header matches" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) + "application/octet-stream" ("content" :: ByteString) + `shouldSatisfy` isJust + + it "returns the Content-Type as the first element of the tuple" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) + "application/octet-stream" ("content" :: ByteString) + `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust) + + it "returns the appropriately serialized representation" $ do + property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) + == Just ("application/json", encode x) + + it "respects the Accept spec ordering" $ do + let highest a b c = maximumBy (compare `on` snd) + [ ("application/octet-stream", a) + , ("application/json", b) + , ("text/plain;charset=utf-8", c) + ] + let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ + addToAccept (Proxy :: Proxy JSON) b $ + addToAccept (Proxy :: Proxy PlainText ) c "" + let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText]) + (acceptH a b c) (i :: Int) + property $ \a b c i -> fst (fromJust $ val a b c i) == fst (highest a b c) + + describe "handleCTypeH" $ do + + it "returns Nothing if the 'Content-Type' header doesn't match" $ do + handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " + `shouldBe` (Nothing :: Maybe (Either String Value)) + + context "the 'Content-Type' header matches" $ do + it "returns Just if the parameter matches" $ do + handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " + `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) + + it "returns Just if there is no parameter" $ do + handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " + `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) + + it "returns Just Left if the decoding fails" $ do + let isJustLeft :: Maybe (Either String Value) -> Bool + isJustLeft (Just (Left _)) = True + isJustLeft _ = False + handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- " + `shouldSatisfy` isJustLeft + + it "returns Just (Right val) if the decoding succeeds" $ do + let val = SomeData "Of cabbages--and kings" 12 + handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + (encode val) + `shouldBe` Just (Right val) + + +data SomeData = SomeData { record1 :: String, record2 :: Int } + deriving (Generic, Eq, Show) + +newtype ZeroToOne = ZeroToOne Float + deriving (Eq, Show, Ord) + +instance FromJSON SomeData + +instance ToJSON SomeData + +instance Arbitrary SomeData where + arbitrary = SomeData <$> arbitrary <*> arbitrary + +instance Arbitrary TextL.Text where + arbitrary = TextL.pack <$> arbitrary + +instance Arbitrary TextS.Text where + arbitrary = TextS.pack <$> arbitrary + +instance Arbitrary ZeroToOne where + arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] + +instance MimeRender OctetStream Int where + toByteString _ = cs . show + +instance MimeRender PlainText Int where + toByteString _ = cs . show + +instance MimeRender PlainText ByteString where + toByteString _ = cs + +instance ToJSON ByteString where + toJSON x = object [ "val" .= x ] + +instance IsString AcceptHeader where + fromString = AcceptHeader . fromString + +instance Arbitrary BSL.ByteString where + arbitrary = cs <$> (arbitrary :: Gen String) + +instance Arbitrary ByteString where + arbitrary = cs <$> (arbitrary :: Gen String) + +addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader +addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) + where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) + cont "" = new + cont old = old `append` ", " `append` new diff --git a/test/Servant/QQSpec.hs b/test/Servant/QQSpec.hs deleted file mode 100644 index 0747f843..00000000 --- a/test/Servant/QQSpec.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.QQSpec where - -import Test.Hspec ( Expectation, Spec, shouldBe, it, describe ) - -import Servant.API - ( (:<|>), - ReqBody, - QueryParam, - MatrixParam, - Put, - Get, - Post, - Capture, - (:>), - sitemap ) - --------------------------------------------------------------------------- --- Types for testing --------------------------------------------------------------------------- - --- Methods --------------------------------------------------------------- -type SimpleGet = [sitemap| -GET hello () -|] -type SimpleGet' = "hello" :> Get () -type SimpleGet'' = "hello" :> Get Bool - -type SimpleGet2 = [sitemap| -GET hello Bool -|] -type SimpleGet2' = "hello" :> Get Bool -type SimpleGet2'' = "hello" :> Get Int - -type SimplePost = [sitemap| -POST hello () -|] -type SimplePost' = "hello" :> Post () -type SimplePost'' = "hello" :> Post Bool - -type SimplePost2 = [sitemap| -POST hello Bool -|] -type SimplePost2' = "hello" :> Post Bool -type SimplePost2'' = "hello" :> Post () - -type SimplePut = [sitemap| -PUT hello () -|] -type SimplePut' = "hello" :> Put () -type SimplePut'' = "hello" :> Put Bool - -type SimplePut2 = [sitemap| -PUT hello Bool -|] -type SimplePut2' = "hello" :> Put Bool -type SimplePut2'' = "hello" :> Put () - --- Parameters ------------------------------------------------------------ - -type SimpleReqBody = [sitemap| -POST hello () -> Bool -|] -type SimpleReqBody' = "hello" :> ReqBody () :> Post Bool -type SimpleReqBody'' = "hello" :> ReqBody Bool :> Post () - -type SimpleCapture = [sitemap| -POST hello/p:Int Bool -|] -type SimpleCapture' = "hello" :> Capture "p" Int :> Post Bool -type SimpleCapture'' = "hello" :> Capture "r" Int :> Post Bool -type SimpleCapture''' = "hello" :> Capture "p" Bool :> Post Bool - -type SimpleQueryParam = [sitemap| -POST hello/?p:Int Bool -|] -type SimpleQueryParam' = "hello" :> QueryParam "p" Int :> Post Bool -type SimpleQueryParam'' = "hello" :> QueryParam "r" Int :> Post Bool -type SimpleQueryParam''' = "hello" :> QueryParam "p" Bool :> Post Bool - -type SimpleMatrixParam = [sitemap| -POST hello;p:Int Bool -|] -type SimpleMatrixParam' = "hello" :> MatrixParam "p" Int :> Post Bool -type SimpleMatrixParam'' = "hello" :> MatrixParam "r" Int :> Post Bool -type SimpleMatrixParam''' = "hello" :> MatrixParam "p" Bool :> Post Bool - -type ComplexMatrixParam = [sitemap| -POST hello;p:Int;q:String/world;r:Int Bool -|] -type ComplexMatrixParam' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Int :> Post Bool -type ComplexMatrixParam'' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "s" Int :> Post Bool -type ComplexMatrixParam''' = "hello" :> MatrixParam "p" Int :> MatrixParam "q" String :> "world" :> MatrixParam "r" Bool :> Post Bool - --- Combinations ---------------------------------------------------------- - -type TwoPaths = [sitemap| -POST hello Bool -GET hello Bool -|] -type TwoPaths' = ("hello" :> Post Bool) :<|> ("hello" :> Get Bool) - -type WithInlineComments = [sitemap| -GET hello Bool -- This is a comment -|] -type WithInlineComments' = "hello" :> Get Bool - -type WithInlineComments2 = [sitemap| -GET hello Bool --- This is a comment -|] -type WithInlineComments2' = "hello" :> Get Bool - - -type WithBlockComments = [sitemap| -GET hello Bool {- -POST hello Bool --} -|] -type WithBlockComments' = "hello" :> Get Bool - -type WithBlockComments2 = [sitemap| -GET hello Bool {- -POST hello Bool --} -POST hello Bool -|] -type WithBlockComments2' = ("hello" :> Get Bool) :<|> ("hello" :> Post Bool) - --------------------------------------------------------------------------- --- Spec --------------------------------------------------------------------------- - -spec :: Spec -spec = do - describe "'sitemap' QuasiQuoter" $ do - it "Handles simple GET types" $ do - (u::SimpleGet) ~= (u::SimpleGet' ) ~> True - (u::SimpleGet) ~= (u::SimpleGet'' ) ~> False - (u::SimpleGet2) ~= (u::SimpleGet2' ) ~> True - (u::SimpleGet2) ~= (u::SimpleGet2'') ~> False - it "Handles simple POST types" $ do - (u::SimplePost) ~= (u::SimplePost' ) ~> True - (u::SimplePost) ~= (u::SimplePost'' ) ~> False - (u::SimplePost2) ~= (u::SimplePost2' ) ~> True - (u::SimplePost2) ~= (u::SimplePost2'') ~> False - it "Handles simple PUT types" $ do - (u::SimplePut) ~= (u::SimplePut' ) ~> True - (u::SimplePut) ~= (u::SimplePut'' ) ~> False - (u::SimplePut2) ~= (u::SimplePut2' ) ~> True - (u::SimplePut2) ~= (u::SimplePut2'') ~> False - it "Handles simple request body types" $ do - (u::SimpleReqBody) ~= (u::SimpleReqBody' ) ~> True - (u::SimpleReqBody) ~= (u::SimpleReqBody'') ~> False - it "Handles simple captures" $ do - (u::SimpleCapture) ~= (u::SimpleCapture' ) ~> True - (u::SimpleCapture) ~= (u::SimpleCapture'') ~> False - (u::SimpleCapture) ~= (u::SimpleCapture''') ~> False - it "Handles simple querystring parameters" $ do - (u::SimpleQueryParam) ~= (u::SimpleQueryParam' ) ~> True - (u::SimpleQueryParam) ~= (u::SimpleQueryParam'') ~> False - (u::SimpleQueryParam) ~= (u::SimpleQueryParam''') ~> False - it "Handles simple matrix parameters" $ do - (u::SimpleMatrixParam) ~= (u::SimpleMatrixParam' ) ~> True - (u::SimpleMatrixParam) ~= (u::SimpleMatrixParam'') ~> False - (u::SimpleMatrixParam) ~= (u::SimpleMatrixParam''') ~> False - it "Handles more complex matrix parameters" $ do - (u::ComplexMatrixParam) ~= (u::ComplexMatrixParam' ) ~> True - (u::ComplexMatrixParam) ~= (u::ComplexMatrixParam'') ~> False - (u::ComplexMatrixParam) ~= (u::ComplexMatrixParam''') ~> False - it "Handles multiples paths" $ do - (u::TwoPaths) ~= (u::TwoPaths') ~> True - it "Ignores inline comments" $ do - (u::WithInlineComments) ~= (u::WithInlineComments') ~> True - (u::WithInlineComments2) ~= (u::WithInlineComments2') ~> True - it "Ignores inline comments" $ do - (u::WithBlockComments) ~= (u::WithBlockComments') ~> True - (u::WithBlockComments2) ~= (u::WithBlockComments2') ~> True - - --------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------- -data HTrue -data HFalse - --- Kiselyov's Type Equality predicate -class TypeEq x y b | x y -> b where { areEq :: x -> y -> Bool } -instance TypeEq x x HTrue where { areEq _ _ = True } -instance b ~ HFalse => TypeEq x y b where { areEq _ _ = False} - -infix 4 ~= -(~=) :: TypeEq x y b => x -> y -> Bool -(~=) = areEq - -u :: a -u = undefined - -infix 3 ~> -(~>) :: (Show a, Eq a) => a -> a -> Expectation -(~>) = shouldBe diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs index c5eee2ad..49f4a5c5 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ b/test/Servant/Utils/LinksSpec.hs @@ -15,22 +15,32 @@ type TestApi = "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete :<|> "parent" :> MatrixParams "name" String :> "child" - :> MatrixParam "gender" String :> Get String + :> MatrixParam "gender" String :> Get '[JSON] String -- Flags :<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete -- All of the verbs - :<|> "get" :> Get () - :<|> "put" :> Put () - :<|> "post" :> ReqBody 'True :> Post () + :<|> "get" :> Get '[JSON] () + :<|> "put" :> Put '[JSON] () + :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] () :<|> "delete" :> Header "ponies" :> Delete :<|> "raw" :> Raw -type TestLink = "hello" :> "hi" :> Get Bool -type TestLink2 = "greet" :> Post Bool -type TestLink3 = "parent" :> "child" :> Get String +type TestLink = "hello" :> "hi" :> Get '[JSON] Bool +type TestLink2 = "greet" :> Post '[PlainText] Bool +type TestLink3 = "parent" :> "child" :> Get '[JSON] String + +type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool +type BadTestLink2 = "greet" :> Get '[PlainText] Bool +type BadTestLink3 = "parent" :> "child" :> MatrixFlag "male" :> Get '[JSON] String + +type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool +type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool + +type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool +type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint @@ -56,7 +66,7 @@ spec = describe "Servant.Utils.Links" $ do let l3 = Proxy :: Proxy ("parent" :> MatrixParams "name" String :> "child" :> MatrixParam "gender" String - :> Get String) + :> Get '[JSON] String) apiLink l3 ["Hubert?x=;&", "Cumberdale"] "Edward?" `shouldBeURI` "parent;name[]=Hubert%3Fx%3D%3B%26;\ \name[]=Cumberdale/child;gender=Edward%3F" @@ -73,8 +83,8 @@ spec = describe "Servant.Utils.Links" $ do apiLink l2 False True `shouldBeURI` "ducks;loud" it "Generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get ())) `shouldBeURI` "get" - apiLink (Proxy :: Proxy ("put" :> Put ())) `shouldBeURI` "put" - apiLink (Proxy :: Proxy ("post" :> Post ())) `shouldBeURI` "post" + apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get" + apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" + apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" apiLink (Proxy :: Proxy ("delete" :> Delete)) `shouldBeURI` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"