git.iko.soy/servant
on 0453cc3 help sign in
servant/src/Servant/API/ContentTypes.hs
211 lines 7.5 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, fromStrict, toStrict)
19import Data.String.Conversions (cs)
20import qualified Data.Text.Lazy as TextL
21import qualified Data.Text.Lazy.Encoding as TextL
22import qualified Data.Text as TextS
23import qualified Data.Text.Encoding as TextS
24import Data.Typeable
25import GHC.Exts (Constraint)
26import qualified Network.HTTP.Media as M
28-- * Provided content types
29data JSON deriving Typeable
30data PlainText deriving Typeable
31data OctetStream deriving Typeable
33-- * Accept class
35-- | Instances of 'Accept' represent mimetypes. They are used for matching
36-- against the @Accept@ HTTP header of the request, and for setting the
37-- @Content-Type@ header of the response
38--
39-- Example:
40--
41-- > instance Accept HTML where
42-- > contentType _ = "text" // "html"
43--
44class Accept ctype where
45 contentType :: Proxy ctype -> M.MediaType
47-- | @application/json;charset=utf-8@
48instance Accept JSON where
49 contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
51-- | @text/plain;charset=utf-8@
52instance Accept PlainText where
53 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
55-- | @application/octet-stream@
56instance Accept OctetStream where
57 contentType _ = "application" M.// "octet-stream"
59newtype AcceptHeader = AcceptHeader BS.ByteString
60 deriving (Eq, Show)
62-- * Render (serializing)
64-- | Instantiate this class to register a way of serializing a type based
65-- on the @Accept@ header.
66--
67-- Example:
68--
69-- > data MyContentType
70-- >
71-- > instance Accept MyContentType where
72-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
73-- >
74-- > instance Show a => MimeRender MyContentType where
75-- > toByteString _ val = pack ("This is MINE! " ++ show val)
76-- >
77-- > type MyAPI = "path" :> Get '[MyContentType] Int
78--
79class Accept ctype => MimeRender ctype a where
80 toByteString :: Proxy ctype -> a -> ByteString
82class AllCTRender list a where
83 -- If the Accept header can be matched, returns (Just) a tuple of the
84 -- Content-Type and response (serialization of @a@ into the appropriate
85 -- mimetype).
86 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
88instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
89 ) => AllCTRender ctyps a where
90 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
91 where pctyps = Proxy :: Proxy ctyps
92 amrs = allMimeRender pctyps val
93 lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
96--------------------------------------------------------------------------
97-- * Unrender
99-- | Instantiate this class to register a way of deserializing a type based
100-- on the request's @Content-Type@ header.
101--
102-- > data MyContentType = MyContentType String
103-- >
104-- > instance Accept MyContentType where
105-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
106-- >
107-- > instance Show a => MimeRender MyContentType where
108-- > fromByteString _ bs = MyContentType $ unpack bs
109-- >
110-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int
111--
112class Accept ctype => MimeUnrender ctype a where
113 fromByteString :: Proxy ctype -> ByteString -> Either String a
115class (IsNonEmpty list) => AllCTUnrender list a where
116 handleCTypeH :: Proxy list
117 -> ByteString -- Content-Type header
118 -> ByteString -- Request body
119 -> Maybe (Either String a)
121instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
122 ) => AllCTUnrender ctyps a where
123 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
124 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
126--------------------------------------------------------------------------
127-- * Utils (Internal)
130--------------------------------------------------------------------------
131-- Check that all elements of list are instances of MimeRender
132--------------------------------------------------------------------------
133class AllMimeRender ls a where
134 allMimeRender :: Proxy ls
135 -> a -- value to serialize
136 -> [(M.MediaType, ByteString)] -- content-types/response pairs
138instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
139 allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
140 where pctyp = Proxy :: Proxy ctyp
142instance ( MimeRender ctyp a
143 , AllMimeRender (ctyp' ': ctyps) a
144 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
145 allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
146 :(allMimeRender pctyps a)
147 where pctyp = Proxy :: Proxy ctyp
148 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
151instance AllMimeRender '[] a where
152 allMimeRender _ _ = []
154--------------------------------------------------------------------------
155-- Check that all elements of list are instances of MimeUnrender
156--------------------------------------------------------------------------
157class AllMimeUnrender ls a where
158 allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
160instance AllMimeUnrender '[] a where
161 allMimeUnrender _ _ = []
163instance ( MimeUnrender ctyp a
164 , AllMimeUnrender ctyps a
165 ) => AllMimeUnrender (ctyp ': ctyps) a where
166 allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
167 :(allMimeUnrender pctyps val)
168 where pctyp = Proxy :: Proxy ctyp
169 pctyps = Proxy :: Proxy ctyps
171type family IsNonEmpty (ls::[*]) :: Constraint where
172 IsNonEmpty (x ': xs) = ()
175--------------------------------------------------------------------------
176-- * MimeRender Instances
178-- | `encode`
179instance ToJSON a => MimeRender JSON a where
180 toByteString _ = encode
182-- | `TextL.encodeUtf8`
183instance MimeRender PlainText TextL.Text where
184 toByteString _ = TextL.encodeUtf8
186-- | `fromStrict . TextS.encodeUtf8`
187instance MimeRender PlainText TextS.Text where
188 toByteString _ = fromStrict . TextS.encodeUtf8
190-- | `id`
191instance MimeRender OctetStream ByteString where
192 toByteString _ = id
194--------------------------------------------------------------------------
195-- * MimeUnrender Instances
197-- | `eitherDecode`
198instance FromJSON a => MimeUnrender JSON a where
199 fromByteString _ = eitherDecode
201-- | `left show . TextL.decodeUtf8'`
202instance MimeUnrender PlainText TextL.Text where
203 fromByteString _ = left show . TextL.decodeUtf8'
205-- | `left show . TextS.decodeUtf8' . toStrict`
206instance MimeUnrender PlainText TextS.Text where
207 fromByteString _ = left show . TextS.decodeUtf8' . toStrict
209-- | `Right . id`
210instance MimeUnrender OctetStream ByteString where
211 fromByteString _ = Right . id