diff --git a/servant.cabal b/servant.cabal index f03d915c..67a39395 100644 --- a/servant.cabal +++ b/servant.cabal @@ -46,6 +46,7 @@ library build-depends: base >=4.7 && <5 , bytestring == 0.10.* + , http-media >= 0.4 && < 0.5 , http-types == 0.8.* , text >= 1 && < 2 , template-haskell >= 2.7 && < 2.10 @@ -54,19 +55,19 @@ library , network-uri >= 2.6 hs-source-dirs: src default-language: Haskell2010 - extensions: DataKinds - , DeriveDataTypeable - , FunctionalDependencies - , KindSignatures - , MultiParamTypeClasses - , PolyKinds - , QuasiQuotes - , ScopedTypeVariables - , TemplateHaskell - , TypeFamilies - , TypeOperators - , UndecidableInstances - , FlexibleInstances + other-extensions: DataKinds + , DeriveDataTypeable + , FunctionalDependencies + , KindSignatures + , MultiParamTypeClasses + , PolyKinds + , QuasiQuotes + , ScopedTypeVariables + , TemplateHaskell + , TypeFamilies + , TypeOperators + , UndecidableInstances + , FlexibleInstances ghc-options: -Wall test-suite spec diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index c3d382dc..74363541 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -1,9 +1,26 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.API.ContentTypes where -import Data.Typeable +import Data.Typeable +import Control.Monad (join) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) +import Data.String.Conversions (cs) +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 @@ -11,3 +28,155 @@ data JavaScript deriving Typeable data CSS 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 + +-- | @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") + +-- | @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 = amr pctyps val + lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs + + + + +-------------------------------------------------------------------------- +-- * Unrender +class Accept ctype => MimeUnrender ctype a where + fromByteString :: Proxy ctype -> ByteString -> Maybe a + +class AllCTUnrender list a where + handleCTypeH :: Proxy list + -> ByteString -- Content-Type header + -> ByteString -- Request body + -> Maybe a + +instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps + ) => AllCTUnrender ctyps a where + handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) + where lkup = amu (Proxy :: Proxy ctyps) body + +-------------------------------------------------------------------------- +-- * Utils (Internal) + + +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeRender +-------------------------------------------------------------------------- +class AllMimeRender ls a where + amr :: Proxy ls + -> a -- value to serialize + -> [(M.MediaType, ByteString)] -- content-types/response pairs + +instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where + amr _ a = [(contentType pctyp, toByteString pctyp a)] + where pctyp = Proxy :: Proxy ctyp + +instance ( MimeRender ctyp a + , MimeRender ctyp' a -- at least two elems to avoid overlap + , AllMimeRender ctyps a + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where + amr _ a = (contentType pctyp, toByteString pctyp a) + :(contentType pctyp', toByteString pctyp' a) + :(amr pctyps a) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + pctyp' = Proxy :: Proxy ctyp' + + +instance AllMimeRender '[] a where + amr _ _ = [] + +-------------------------------------------------------------------------- +-- Check that all elements of list are instances of MimeUnrender +-------------------------------------------------------------------------- +class AllMimeUnrender ls a where + amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)] + +instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where + amu _ val = [(contentType pctyp, fromByteString pctyp val)] + where pctyp = Proxy :: Proxy ctyp + +instance ( MimeUnrender ctyp a + , MimeUnrender ctyp' a + , AllMimeUnrender ctyps a + ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where + amu _ val = (contentType pctyp, fromByteString pctyp val) + :(contentType pctyp', fromByteString pctyp' val) + :(amu pctyps val) + where pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps + pctyp' = Proxy :: Proxy ctyp' + +type family IsNonEmpty (ls::[*]) :: Constraint where + IsNonEmpty '[] = 'False ~ 'True + IsNonEmpty x = ()