git.iko.soy/servant
on 1a200f1 help sign in
servant/src/Servant/API/ContentTypes.hs
298 lines 11 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.Applicative ((<*))
15import Control.Arrow (left)
16import Control.Monad
17import Data.Aeson (FromJSON, ToJSON, Value,
18 encode, parseJSON)
19import Data.Aeson.Parser (value)
20import Data.Aeson.Types (parseEither)
21import Data.Attoparsec.ByteString (endOfInput, parseOnly)
22import qualified Data.ByteString as BS
23import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
24import qualified Data.ByteString.Lazy as B
25import Data.Monoid
26import Data.String.Conversions (cs)
27import qualified Data.Text as TextS
28import qualified Data.Text.Encoding as TextS
29import qualified Data.Text.Lazy as TextL
30import qualified Data.Text.Lazy.Encoding as TextL
31import Data.Typeable
32import GHC.Exts (Constraint)
33import qualified Network.HTTP.Media as M
34import Network.URI (escapeURIString, isUnreserved,
35 unEscapeString)
37-- * Provided content types
38data JSON deriving Typeable
39data PlainText deriving Typeable
40data FormUrlEncoded deriving Typeable
41data OctetStream deriving Typeable
43-- * Accept class
45-- | Instances of 'Accept' represent mimetypes. They are used for matching
46-- against the @Accept@ HTTP header of the request, and for setting the
47-- @Content-Type@ header of the response
48--
49-- Example:
50--
51-- > instance Accept HTML where
52-- > contentType _ = "text" // "html"
53--
54class Accept ctype where
55 contentType :: Proxy ctype -> M.MediaType
57-- | @application/json@
58instance Accept JSON where
59 contentType _ = "application" M.// "json"
61-- | @application/x-www-form-urlencoded@
62instance Accept FormUrlEncoded where
63 contentType _ = "application" M.// "x-www-form-urlencoded"
65-- | @text/plain;charset=utf-8@
66instance Accept PlainText where
67 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
69-- | @application/octet-stream@
70instance Accept OctetStream where
71 contentType _ = "application" M.// "octet-stream"
73newtype AcceptHeader = AcceptHeader BS.ByteString
74 deriving (Eq, Show)
76-- * Render (serializing)
78-- | Instantiate this class to register a way of serializing a type based
79-- on the @Accept@ header.
80--
81-- Example:
82--
83-- > data MyContentType
84-- >
85-- > instance Accept MyContentType where
86-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
87-- >
88-- > instance Show a => MimeRender MyContentType where
89-- > toByteString _ val = pack ("This is MINE! " ++ show val)
90-- >
91-- > type MyAPI = "path" :> Get '[MyContentType] Int
92--
93class Accept ctype => MimeRender ctype a where
94 toByteString :: Proxy ctype -> a -> ByteString
96class AllCTRender list a where
97 -- If the Accept header can be matched, returns (Just) a tuple of the
98 -- Content-Type and response (serialization of @a@ into the appropriate
99 -- mimetype).
100 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
102instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
103 ) => AllCTRender ctyps a where
104 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
105 where pctyps = Proxy :: Proxy ctyps
106 amrs = allMimeRender pctyps val
107 lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
110--------------------------------------------------------------------------
111-- * Unrender
113-- | Instantiate this class to register a way of deserializing a type based
114-- on the request's @Content-Type@ header.
115--
116-- > data MyContentType = MyContentType String
117-- >
118-- > instance Accept MyContentType where
119-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
120-- >
121-- > instance Show a => MimeUnrender MyContentType where
122-- > fromByteString _ bs = MyContentType $ unpack bs
123-- >
124-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int
125--
126class Accept ctype => MimeUnrender ctype a where
127 fromByteString :: Proxy ctype -> ByteString -> Either String a
129class (IsNonEmpty list) => AllCTUnrender list a where
130 handleCTypeH :: Proxy list
131 -> ByteString -- Content-Type header
132 -> ByteString -- Request body
133 -> Maybe (Either String a)
135instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
136 ) => AllCTUnrender ctyps a where
137 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
138 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
140--------------------------------------------------------------------------
141-- * Utils (Internal)
144--------------------------------------------------------------------------
145-- Check that all elements of list are instances of MimeRender
146--------------------------------------------------------------------------
147class AllMimeRender ls a where
148 allMimeRender :: Proxy ls
149 -> a -- value to serialize
150 -> [(M.MediaType, ByteString)] -- content-types/response pairs
152instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
153 allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
154 where pctyp = Proxy :: Proxy ctyp
156instance ( MimeRender ctyp a
157 , AllMimeRender (ctyp' ': ctyps) a
158 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
159 allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
160 :(allMimeRender pctyps a)
161 where pctyp = Proxy :: Proxy ctyp
162 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
165instance AllMimeRender '[] a where
166 allMimeRender _ _ = []
168--------------------------------------------------------------------------
169-- Check that all elements of list are instances of MimeUnrender
170--------------------------------------------------------------------------
171class AllMimeUnrender ls a where
172 allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
174instance AllMimeUnrender '[] a where
175 allMimeUnrender _ _ = []
177instance ( MimeUnrender ctyp a
178 , AllMimeUnrender ctyps a
179 ) => AllMimeUnrender (ctyp ': ctyps) a where
180 allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
181 :(allMimeUnrender pctyps val)
182 where pctyp = Proxy :: Proxy ctyp
183 pctyps = Proxy :: Proxy ctyps
185type family IsNonEmpty (ls::[*]) :: Constraint where
186 IsNonEmpty (x ': xs) = ()
189--------------------------------------------------------------------------
190-- * MimeRender Instances
192-- | `encode`
193instance ToJSON a => MimeRender JSON a where
194 toByteString _ = encode
196-- | `encodeFormUrlEncoded . toFormUrlEncoded`
197-- Note that the `fromByteString p (toByteString p x) == Right x` law only
198-- holds if every element of x is non-null (i.e., not `("", "")`)
199instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
200 toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
202-- | `TextL.encodeUtf8`
203instance MimeRender PlainText TextL.Text where
204 toByteString _ = TextL.encodeUtf8
206-- | `fromStrict . TextS.encodeUtf8`
207instance MimeRender PlainText TextS.Text where
208 toByteString _ = fromStrict . TextS.encodeUtf8
210-- | `id`
211instance MimeRender OctetStream ByteString where
212 toByteString _ = id
214-- | `fromStrict`
215instance MimeRender OctetStream BS.ByteString where
216 toByteString _ = fromStrict
219--------------------------------------------------------------------------
220-- * MimeUnrender Instances
222-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
223-- objects and arrays.
224eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
225eitherDecodeLenient input = do
226 v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
227 parseEither parseJSON v
229-- | `eitherDecode`
230instance FromJSON a => MimeUnrender JSON a where
231 fromByteString _ = eitherDecodeLenient
233-- | `decodeFormUrlEncoded >=> fromFormUrlEncoded`
234-- Note that the `fromByteString p (toByteString p x) == Right x` law only
235-- holds if every element of x is non-null (i.e., not `("", "")`)
236instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
237 fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
239-- | `left show . TextL.decodeUtf8'`
240instance MimeUnrender PlainText TextL.Text where
241 fromByteString _ = left show . TextL.decodeUtf8'
243-- | `left show . TextS.decodeUtf8' . toStrict`
244instance MimeUnrender PlainText TextS.Text where
245 fromByteString _ = left show . TextS.decodeUtf8' . toStrict
247-- | `Right . id`
248instance MimeUnrender OctetStream ByteString where
249 fromByteString _ = Right . id
251-- | `Right . toStrict`
252instance MimeUnrender OctetStream BS.ByteString where
253 fromByteString _ = Right . toStrict
256--------------------------------------------------------------------------
257-- * FormUrlEncoded
259-- | A type that can be converted to @application/x-www-form-urlencoded@
260class ToFormUrlEncoded a where
261 toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)]
263instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where
264 toFormUrlEncoded = id
266-- | A type that can be converted from @application/x-www-form-urlencoded@,
267-- with the possibility of failure.
268class FromFormUrlEncoded a where
269 fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a
271instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where
272 fromFormUrlEncoded = return
274encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString
275encodeFormUrlEncoded xs =
276 let escape :: TextS.Text -> ByteString
277 escape = cs . escapeURIString isUnreserved . cs
278 encodePair :: (TextS.Text, TextS.Text) -> ByteString
279 encodePair (k, "") = escape k
280 encodePair (k, v) = escape k <> "=" <> escape v
281 in B.intercalate "&" $ map encodePair xs
283decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]
284decodeFormUrlEncoded "" = return []
285decodeFormUrlEncoded q = do
286 let xs :: [TextS.Text]
287 xs = TextS.splitOn "&" . cs $ q
288 parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)
289 parsePair p =
290 case TextS.splitOn "=" p of
291 [k,v] -> return ( unescape k
292 , unescape v
293 )
294 [k] -> return ( unescape k, "" )
295 _ -> Left $ "not a valid pair: " <> cs p
296 unescape :: TextS.Text -> TextS.Text
297 unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"
298 mapM parsePair xs