git.iko.soy/servant
on d299bd3 help sign in
servant/src/Servant/API/ContentTypes.hs
186 lines 6.6 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
12module Servant.API.ContentTypes where
14import Control.Arrow (left)
15import Data.Aeson (FromJSON, ToJSON, eitherDecode,
16 encode)
17import qualified Data.ByteString as BS
18import Data.ByteString.Lazy (ByteString)
19import Data.String.Conversions (cs)
20import qualified Data.Text.Lazy as Text
21import qualified Data.Text.Lazy.Encoding as Text
22import Data.Typeable
23import GHC.Exts (Constraint)
24import qualified Network.HTTP.Media as M
26-- * Provided content types
27data JSON deriving Typeable
28data PlainText deriving Typeable
29data OctetStream deriving Typeable
31-- * Accept class
33-- | Instances of 'Accept' represent mimetypes. They are used for matching
34-- against the @Accept@ HTTP header of the request, and for setting the
35-- @Content-Type@ header of the response
36--
37-- Example:
38--
39-- > instance Accept HTML where
40-- > contentType _ = "text" // "html"
41--
42class Accept ctype where
43 contentType :: Proxy ctype -> M.MediaType
45-- | @application/json;charset=utf-8@
46instance Accept JSON where
47 contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
49-- | @text/plain;charset=utf-8@
50instance Accept PlainText where
51 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
53-- | @application/octet-stream@
54instance Accept OctetStream where
55 contentType _ = "application" M.// "octet-stream"
57newtype AcceptHeader = AcceptHeader BS.ByteString
58 deriving (Eq, Show)
60-- * Render (serializing)
62-- | Instantiate this class to register a way of serializing a type based
63-- on the @Accept@ header.
64--
65-- Example:
66--
67-- > data MyContentType
68-- >
69-- > instance Accept MyContentType where
70-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
71-- >
72-- > instance Show a => MimeRender MyContentType where
73-- > toByteString _ val = pack ("This is MINE! " ++ show val)
74-- >
75-- > type MyAPI = "path" :> Get '[MyContentType] Int
76class Accept ctype => MimeRender ctype a where
77 toByteString :: Proxy ctype -> a -> ByteString
79class AllCTRender list a where
80 -- If the Accept header can be matched, returns (Just) a tuple of the
81 -- Content-Type and response (serialization of @a@ into the appropriate
82 -- mimetype).
83 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
85instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
86 ) => AllCTRender ctyps a where
87 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
88 where pctyps = Proxy :: Proxy ctyps
89 amrs = allMimeRender pctyps val
90 lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
93--------------------------------------------------------------------------
94-- * Unrender
95class Accept ctype => MimeUnrender ctype a where
96 fromByteString :: Proxy ctype -> ByteString -> Either String a
98class (IsNonEmpty list) => AllCTUnrender list a where
99 handleCTypeH :: Proxy list
100 -> ByteString -- Content-Type header
101 -> ByteString -- Request body
102 -> Maybe (Either String a)
104instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
105 ) => AllCTUnrender ctyps a where
106 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
107 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
109--------------------------------------------------------------------------
110-- * Utils (Internal)
113--------------------------------------------------------------------------
114-- Check that all elements of list are instances of MimeRender
115--------------------------------------------------------------------------
116class AllMimeRender ls a where
117 allMimeRender :: Proxy ls
118 -> a -- value to serialize
119 -> [(M.MediaType, ByteString)] -- content-types/response pairs
121instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
122 allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
123 where pctyp = Proxy :: Proxy ctyp
125instance ( MimeRender ctyp a
126 , AllMimeRender (ctyp' ': ctyps) a
127 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
128 allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
129 :(allMimeRender pctyps a)
130 where pctyp = Proxy :: Proxy ctyp
131 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
134instance AllMimeRender '[] a where
135 allMimeRender _ _ = []
137--------------------------------------------------------------------------
138-- Check that all elements of list are instances of MimeUnrender
139--------------------------------------------------------------------------
140class AllMimeUnrender ls a where
141 allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
143instance AllMimeUnrender '[] a where
144 allMimeUnrender _ _ = []
146instance ( MimeUnrender ctyp a
147 , AllMimeUnrender ctyps a
148 ) => AllMimeUnrender (ctyp ': ctyps) a where
149 allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
150 :(allMimeUnrender pctyps val)
151 where pctyp = Proxy :: Proxy ctyp
152 pctyps = Proxy :: Proxy ctyps
154type family IsNonEmpty (ls::[*]) :: Constraint where
155 IsNonEmpty (x ': xs) = ()
158--------------------------------------------------------------------------
159-- * MimeRender Instances
161-- | `encode`
162instance ToJSON a => MimeRender JSON a where
163 toByteString _ = encode
165-- | `Text.encodeUtf8`
166instance MimeRender PlainText Text.Text where
167 toByteString _ = Text.encodeUtf8
169-- | `id`
170instance MimeRender OctetStream ByteString where
171 toByteString _ = id
173--------------------------------------------------------------------------
174-- * MimeUnrender Instances
176-- | `eitherDecode`
177instance FromJSON a => MimeUnrender JSON a where
178 fromByteString _ = eitherDecode
180-- | `left show . Text.decodeUtf8'`
181instance MimeUnrender PlainText Text.Text where
182 fromByteString _ = left show . Text.decodeUtf8'
184-- | `Right . id`
185instance MimeUnrender OctetStream ByteString where
186 fromByteString _ = Right . id