git.iko.soy/typeable/servant
on 1d378e6 help sign in
typeable/servant/src/Servant/API/ContentTypes.hs
281 lines 10 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 Control.Monad
16import Data.Aeson (FromJSON, ToJSON, eitherDecode,
17 encode)
18import qualified Data.ByteString as BS
19import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
20import qualified Data.ByteString.Lazy as B
21import Data.String.Conversions (cs)
22import Data.Monoid
23import qualified Data.Text.Lazy as TextL
24import qualified Data.Text.Lazy.Encoding as TextL
25import qualified Data.Text as TextS
26import qualified Data.Text.Encoding as TextS
27import Data.Typeable
28import GHC.Exts (Constraint)
29import qualified Network.HTTP.Media as M
30import Network.URI (unEscapeString, escapeURIString,
31 isUnreserved)
33-- * Provided content types
34data JSON deriving Typeable
35data PlainText deriving Typeable
36data FormUrlEncoded deriving Typeable
37data OctetStream deriving Typeable
39-- * Accept class
41-- | Instances of 'Accept' represent mimetypes. They are used for matching
42-- against the @Accept@ HTTP header of the request, and for setting the
43-- @Content-Type@ header of the response
44--
45-- Example:
46--
47-- > instance Accept HTML where
48-- > contentType _ = "text" // "html"
49--
50class Accept ctype where
51 contentType :: Proxy ctype -> M.MediaType
53-- | @application/json@
54instance Accept JSON where
55 contentType _ = "application" M.// "json"
57-- | @application/x-www-form-urlencoded@
58instance Accept FormUrlEncoded where
59 contentType _ = "application" M.// "x-www-form-urlencoded"
61-- | @text/plain;charset=utf-8@
62instance Accept PlainText where
63 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
65-- | @application/octet-stream@
66instance Accept OctetStream where
67 contentType _ = "application" M.// "octet-stream"
69newtype AcceptHeader = AcceptHeader BS.ByteString
70 deriving (Eq, Show)
72-- * Render (serializing)
74-- | Instantiate this class to register a way of serializing a type based
75-- on the @Accept@ header.
76--
77-- Example:
78--
79-- > data MyContentType
80-- >
81-- > instance Accept MyContentType where
82-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
83-- >
84-- > instance Show a => MimeRender MyContentType where
85-- > toByteString _ val = pack ("This is MINE! " ++ show val)
86-- >
87-- > type MyAPI = "path" :> Get '[MyContentType] Int
88--
89class Accept ctype => MimeRender ctype a where
90 toByteString :: Proxy ctype -> a -> ByteString
92class AllCTRender list a where
93 -- If the Accept header can be matched, returns (Just) a tuple of the
94 -- Content-Type and response (serialization of @a@ into the appropriate
95 -- mimetype).
96 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
98instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
99 ) => AllCTRender ctyps a where
100 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
101 where pctyps = Proxy :: Proxy ctyps
102 amrs = allMimeRender pctyps val
103 lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
106--------------------------------------------------------------------------
107-- * Unrender
109-- | Instantiate this class to register a way of deserializing a type based
110-- on the request's @Content-Type@ header.
111--
112-- > data MyContentType = MyContentType String
113-- >
114-- > instance Accept MyContentType where
115-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
116-- >
117-- > instance Show a => MimeUnrender MyContentType where
118-- > fromByteString _ bs = MyContentType $ unpack bs
119-- >
120-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int
121--
122class Accept ctype => MimeUnrender ctype a where
123 fromByteString :: Proxy ctype -> ByteString -> Either String a
125class (IsNonEmpty list) => AllCTUnrender list a where
126 handleCTypeH :: Proxy list
127 -> ByteString -- Content-Type header
128 -> ByteString -- Request body
129 -> Maybe (Either String a)
131instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
132 ) => AllCTUnrender ctyps a where
133 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
134 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
136--------------------------------------------------------------------------
137-- * Utils (Internal)
140--------------------------------------------------------------------------
141-- Check that all elements of list are instances of MimeRender
142--------------------------------------------------------------------------
143class AllMimeRender ls a where
144 allMimeRender :: Proxy ls
145 -> a -- value to serialize
146 -> [(M.MediaType, ByteString)] -- content-types/response pairs
148instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
149 allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
150 where pctyp = Proxy :: Proxy ctyp
152instance ( MimeRender ctyp a
153 , AllMimeRender (ctyp' ': ctyps) a
154 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
155 allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
156 :(allMimeRender pctyps a)
157 where pctyp = Proxy :: Proxy ctyp
158 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
161instance AllMimeRender '[] a where
162 allMimeRender _ _ = []
164--------------------------------------------------------------------------
165-- Check that all elements of list are instances of MimeUnrender
166--------------------------------------------------------------------------
167class AllMimeUnrender ls a where
168 allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
170instance AllMimeUnrender '[] a where
171 allMimeUnrender _ _ = []
173instance ( MimeUnrender ctyp a
174 , AllMimeUnrender ctyps a
175 ) => AllMimeUnrender (ctyp ': ctyps) a where
176 allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
177 :(allMimeUnrender pctyps val)
178 where pctyp = Proxy :: Proxy ctyp
179 pctyps = Proxy :: Proxy ctyps
181type family IsNonEmpty (ls::[*]) :: Constraint where
182 IsNonEmpty (x ': xs) = ()
185--------------------------------------------------------------------------
186-- * MimeRender Instances
188-- | `encode`
189instance ToJSON a => MimeRender JSON a where
190 toByteString _ = encode
192-- | `encodeFormUrlEncoded . toFormUrlEncoded`
193instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
194 toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
196-- | `TextL.encodeUtf8`
197instance MimeRender PlainText TextL.Text where
198 toByteString _ = TextL.encodeUtf8
200-- | `fromStrict . TextS.encodeUtf8`
201instance MimeRender PlainText TextS.Text where
202 toByteString _ = fromStrict . TextS.encodeUtf8
204-- | `id`
205instance MimeRender OctetStream ByteString where
206 toByteString _ = id
208-- | `fromStrict`
209instance MimeRender OctetStream BS.ByteString where
210 toByteString _ = fromStrict
213--------------------------------------------------------------------------
214-- * MimeUnrender Instances
216-- | `eitherDecode`
217instance FromJSON a => MimeUnrender JSON a where
218 fromByteString _ = eitherDecode
220-- | `decodeFormUrlEncoded >=> fromFormUrlEncoded`
221instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
222 fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
224-- | `left show . TextL.decodeUtf8'`
225instance MimeUnrender PlainText TextL.Text where
226 fromByteString _ = left show . TextL.decodeUtf8'
228-- | `left show . TextS.decodeUtf8' . toStrict`
229instance MimeUnrender PlainText TextS.Text where
230 fromByteString _ = left show . TextS.decodeUtf8' . toStrict
232-- | `Right . id`
233instance MimeUnrender OctetStream ByteString where
234 fromByteString _ = Right . id
236-- | `Right . toStrict`
237instance MimeUnrender OctetStream BS.ByteString where
238 fromByteString _ = Right . toStrict
241--------------------------------------------------------------------------
242-- * FormUrlEncoded
244-- | A type that can be converted to @application/x-www-form-urlencoded@
245class ToFormUrlEncoded a where
246 toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)]
248instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where
249 toFormUrlEncoded = id
251-- | A type that can be converted from @application/x-www-form-urlencoded@,
252-- with the possibility of failure.
253class FromFormUrlEncoded a where
254 fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a
256instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where
257 fromFormUrlEncoded = return
259encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString
260encodeFormUrlEncoded xs =
261 let escape :: TextS.Text -> ByteString
262 escape = cs . escapeURIString isUnreserved . cs
263 encodePair :: (TextS.Text, TextS.Text) -> ByteString
264 encodePair (k, v) = escape k <> "=" <> escape v
265 in B.intercalate "&" $ map encodePair xs
267decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]
268decodeFormUrlEncoded "" = return []
269decodeFormUrlEncoded q = do
270 let xs :: [TextS.Text]
271 xs = TextS.splitOn "&" . cs $ q
272 parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)
273 parsePair p =
274 case TextS.splitOn "=" p of
275 [k,v] -> return ( unescape k
276 , unescape v
277 )
278 _ -> Left $ "not a valid pair: " <> cs p
279 unescape :: TextS.Text -> TextS.Text
280 unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"
281 mapM parsePair xs