diff --git a/servant.cabal b/servant.cabal index 347ef56c..91fcb190 100644 --- a/servant.cabal +++ b/servant.cabal @@ -45,6 +45,7 @@ library Servant.Utils.Links build-depends: base >=4.7 && <5 + , aeson >= 0.7 , bytestring == 0.10.* , http-media >= 0.4 && < 0.6 , http-types == 0.8.* diff --git a/src/Servant/API.hs b/src/Servant/API.hs index b13b4630..56beaaba 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -46,9 +46,8 @@ module Servant.API ( import Servant.API.Alternative ( (:<|>)(..) ) import Servant.API.Capture ( Capture ) -import Servant.API.ContentTypes ( HTML, XML, JSON, JavaScript, CSS - , PlainText, OctetStream, MimeRender(..) - , MimeUnrender(..)) +import Servant.API.ContentTypes ( JSON , PlainText, OctetStream + , MimeRender(..) , MimeUnrender(..)) import Servant.API.Delete ( Delete ) import Servant.API.Get ( Get ) import Servant.API.Header ( Header ) diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index d141f494..468d8509 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# 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) import Data.String.Conversions (cs) +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.Encoding as Text import Data.Typeable import GHC.Exts (Constraint) import qualified Network.HTTP.Media as M -- * Provided content types -data XML deriving Typeable -data HTML deriving Typeable data JSON deriving Typeable -data JavaScript deriving Typeable -data CSS deriving Typeable data PlainText deriving Typeable data OctetStream deriving Typeable @@ -41,26 +42,10 @@ data OctetStream deriving Typeable class Accept ctype where contentType :: Proxy ctype -> M.MediaType --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - -- | @application/json;charset=utf-8@ instance Accept JSON where contentType _ = "application" M.// "json" M./: ("charset", "utf-8") --- | @application/xml;charset=utf-8@ -instance Accept XML where - contentType _ = "application" M.// "xml" M./: ("charset", "utf-8") - --- | @application/javascript;charset=utf-8@ -instance Accept JavaScript where - contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8") - --- | @text/css;charset=utf-8@ -instance Accept CSS where - contentType _ = "text" M.// "css" M./: ("charset", "utf-8") - -- | @text/plain;charset=utf-8@ instance Accept PlainText where contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") @@ -168,3 +153,34 @@ instance ( MimeUnrender ctyp a type family IsNonEmpty (ls::[*]) :: Constraint where IsNonEmpty (x ': xs) = () + + +-------------------------------------------------------------------------- +-- * MimeRender Instances + +-- | `encode` +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +-- | `Text.encodeUtf8` +instance MimeRender PlainText Text.Text where + toByteString _ = Text.encodeUtf8 + +-- | `id` +instance MimeRender OctetStream ByteString where + toByteString _ = id + +-------------------------------------------------------------------------- +-- * MimeUnrender Instances + +-- | `eitherDecode` +instance FromJSON a => MimeUnrender JSON a where + fromByteString _ = eitherDecode + +-- | `left show . Text.decodeUtf8'` +instance MimeUnrender PlainText Text.Text where + fromByteString _ = left show . Text.decodeUtf8' + +-- | `Right . id` +instance MimeUnrender OctetStream ByteString where + fromByteString _ = Right . id diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs index 870a927c..49f4a5c5 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ b/test/Servant/Utils/LinksSpec.hs @@ -29,15 +29,15 @@ type TestApi = :<|> "raw" :> Raw type TestLink = "hello" :> "hi" :> Get '[JSON] Bool -type TestLink2 = "greet" :> Post '[XML] 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 '[XML] Bool +type BadTestLink2 = "greet" :> Get '[PlainText] Bool type BadTestLink3 = "parent" :> "child" :> MatrixFlag "male" :> Get '[JSON] String -type BadTestLink' = "hello" :> "hi" :> Get '[HTML] Bool -type BadTestLink'2 = "greet" :> Get '[HTML] Bool +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