Merge pull request #9 from haskell-servant/jkarni/content-types

Jkarni/content types

default.nix

@@ -0,0 +1,12 @@
+{ pkgs ? import <nixpkgs> { 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 = {};
+}

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
+    , aeson >= 0.7
-    , template-haskell
+    , 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

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(..) )

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

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]
+-- > type MyApi = "books" :> Get '[JSON] [Book]
-data Get a
+data Get (contentTypes::[*]) a
   deriving Typeable

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
+-- > type MyApi = "books" :> ReqBody Book :> Patch '[JSON] Book
-data Patch a
+data Patch (contentTypes::[*]) a
   deriving Typeable

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
+-- > type MyApi = "books" :> ReqBody Book :> Post '[JSON] Book
-data Post a
+data Post (contentTypes::[*]) a
   deriving Typeable

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
+-- > type MyApi = "books" :> Capture "isbn" Text :> ReqBody Book :> Put '[JSON] Book
-data Put a
+data Put (contentTypes::[*]) a
   deriving Typeable

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

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
+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post Book
-data ReqBody a
+data ReqBody (contentTypes::[*]) a

src/Servant/QQ.hs

@@ -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.
---
---     * @.../<var>:<type>/...@ becomes a capture
---     * @.../?<var>:<type>@ becomes a query parameter
---     * @<method>   ...  <typ>@ becomes a method returning @<typ>@
---     * @<method>   ...  <typ1> -> <typ2>@ becomes a method with request
---       body of @<typ1>@ and returning @<typ2>@
---
--- 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
-                      }

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 @@
 -- <BLANKLINE>
 -- <interactive>: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
+instance HasLink (Get y r) where
-    type MkLink (Get r) = URI
+    type MkLink (Get y r) = URI
     toLink _ = linkURI
 
-instance HasLink (Post r) where
+instance HasLink (Post y r) where
-    type MkLink (Post r) = URI
+    type MkLink (Post y r) = URI
     toLink _ = linkURI
 
-instance HasLink (Put r) where
+instance HasLink (Put y r) where
-    type MkLink (Put r) = URI
+    type MkLink (Put y r) = URI
     toLink _ = linkURI
 
 instance HasLink Delete where

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

test/Servant/QQSpec.hs

@@ -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

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 ()
+  :<|> "get" :> Get '[JSON] ()
-  :<|> "put" :> Put ()
+  :<|> "put" :> Put '[JSON] ()
-  :<|> "post" :> ReqBody 'True :> Post ()
+  :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] ()
   :<|> "delete" :> Header "ponies" :> Delete
   :<|> "raw" :> Raw
 
-type TestLink = "hello" :> "hi" :> Get Bool
+type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
-type TestLink2 = "greet" :> Post Bool
+type TestLink2 = "greet" :> Post '[PlainText] Bool
-type TestLink3 = "parent" :> "child" :> Get String
+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 ("get" :> Get '[JSON] ())) `shouldBeURI` "get"
-        apiLink (Proxy :: Proxy ("put" :> Put ())) `shouldBeURI` "put"
+        apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
-        apiLink (Proxy :: Proxy ("post" :> Post ())) `shouldBeURI` "post"
+        apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
         apiLink (Proxy :: Proxy ("delete" :> Delete)) `shouldBeURI` "delete"
         apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"