@@ -11,7 +11,8 @@
1111module Servant.Server.ContentTypes where
1212
1313import Control.Monad (join)
14−import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode)
14+import Control.Arrow (left)
15+import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode)
1516import Data.ByteString.Lazy (ByteString)
1617import qualified Data.ByteString as BS
1718import Data.Proxy (Proxy(..))
@@ -23,86 +24,7 @@ import qualified Network.HTTP.Media as M
2324
2425
2526import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
26− , OctetStream)
27−
28−-- * Accept class
29−
30−-- | Instances of 'Accept' represent mimetypes. They are used for matching
31−-- against the @Accept@ HTTP header of the request, and for setting the
32−-- @Content-Type@ header of the response
33−--
34−-- Example:
35−--
36−-- > instance Accept HTML where
37−-- > contentType _ = "text" // "html"
38−--
39−class Accept ctype where
40− contentType :: Proxy ctype -> M.MediaType
41−
42−-- | @text/html;charset=utf-8@
43−instance Accept HTML where
44− contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
45−
46−-- | @application/json;charset=utf-8@
47−instance Accept JSON where
48− contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
49−
50−-- | @application/xml;charset=utf-8@
51−instance Accept XML where
52− contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
53−
54−-- | @application/javascript;charset=utf-8@
55−instance Accept JavaScript where
56− contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
57−
58−-- | @text/css;charset=utf-8@
59−instance Accept CSS where
60− contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
61−
62−-- | @text/plain;charset=utf-8@
63−instance Accept PlainText where
64− contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
65−
66−-- | @application/octet-stream@
67−instance Accept OctetStream where
68− contentType _ = "application" M.// "octet-stream"
69−
70−newtype AcceptHeader = AcceptHeader BS.ByteString
71− deriving (Eq, Show)
72−
73−-- * Render (serializing)
74−
75−-- | Instantiate this class to register a way of serializing a type based
76−-- on the @Accept@ header.
77−--
78−-- Example:
79−--
80−-- > data MyContentType
81−-- >
82−-- > instance Accept MyContentType where
83−-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
84−-- >
85−-- > instance Show a => MimeRender MyContentType where
86−-- > toByteString _ val = pack ("This is MINE! " ++ show val)
87−-- >
88−-- > type MyAPI = "path" :> Get '[MyContentType] Int
89−class Accept ctype => MimeRender ctype a where
90− toByteString :: Proxy ctype -> a -> ByteString
91−
92−class 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)
97−
98−instance ( 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 = amr pctyps val
103− lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
104−
105−
27+ , OctetStream, MimeRender(..), MimeUnrender(..) )
10628
10729
10830--------------------------------------------------------------------------
@@ -116,86 +38,14 @@ instance ToJSON a => MimeRender JSON a where
11638instance MimeRender PlainText Text.Text where
11739 toByteString _ = Text.encodeUtf8
11840
119−--------------------------------------------------------------------------
120−-- * Unrender
121−class Accept ctype => MimeUnrender ctype a where
122− fromByteString :: Proxy ctype -> ByteString -> Maybe a
123−
124−class AllCTUnrender list a where
125− handleCTypeH :: Proxy list
126− -> ByteString -- Content-Type header
127− -> ByteString -- Request body
128− -> Maybe a
129−
130−instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
131− ) => AllCTUnrender ctyps a where
132− handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
133− where lkup = amu (Proxy :: Proxy ctyps) body
134−
135−--------------------------------------------------------------------------
136−-- * Utils (Internal)
137−
138−
139−--------------------------------------------------------------------------
140−-- Check that all elements of list are instances of MimeRender
141−--------------------------------------------------------------------------
142−class AllMimeRender ls a where
143− amr :: Proxy ls
144− -> a -- value to serialize
145− -> [(M.MediaType, ByteString)] -- content-types/response pairs
146−
147−instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
148− amr _ a = [(contentType pctyp, toByteString pctyp a)]
149− where pctyp = Proxy :: Proxy ctyp
150−
151−instance ( MimeRender ctyp a
152− , MimeRender ctyp' a -- at least two elems to avoid overlap
153− , AllMimeRender ctyps a
154− ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
155− amr _ a = (contentType pctyp, toByteString pctyp a)
156− :(contentType pctyp', toByteString pctyp' a)
157− :(amr pctyps a)
158− where pctyp = Proxy :: Proxy ctyp
159− pctyps = Proxy :: Proxy ctyps
160− pctyp' = Proxy :: Proxy ctyp'
161−
162−
163−instance AllMimeRender '[] a where
164− amr _ _ = []
165−
166−--------------------------------------------------------------------------
167−-- Check that all elements of list are instances of MimeUnrender
168−--------------------------------------------------------------------------
169−class AllMimeUnrender ls a where
170− amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
171−
172−instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
173− amu _ val = [(contentType pctyp, fromByteString pctyp val)]
174− where pctyp = Proxy :: Proxy ctyp
175−
176−instance ( MimeUnrender ctyp a
177− , MimeUnrender ctyp' a
178− , AllMimeUnrender ctyps a
179− ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
180− amu _ val = (contentType pctyp, fromByteString pctyp val)
181− :(contentType pctyp', fromByteString pctyp' val)
182− :(amu pctyps val)
183− where pctyp = Proxy :: Proxy ctyp
184− pctyps = Proxy :: Proxy ctyps
185− pctyp' = Proxy :: Proxy ctyp'
186−
187−type family IsNonEmpty (ls::[*]) :: Constraint where
188− IsNonEmpty '[] = 'False ~ 'True
189− IsNonEmpty x = ()
190−
19141--------------------------------------------------------------------------
19242-- * MimeUnrender Instances
19343
19444-- | @decode@
19545instance FromJSON a => MimeUnrender JSON a where
196− fromByteString _ = decode
46+ fromByteString _ = eitherDecode
19747
19848-- | @Text.decodeUtf8'@
19949instance MimeUnrender PlainText Text.Text where
200− fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
50+ fromByteString _ = left show . Text.decodeUtf8'
20151