@@ -0,0 +1,220 @@
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 #-}
12+module Servant.API.ContentTypes where
13+
14+import Control.Arrow (left)
15+import Data.Aeson (FromJSON, ToJSON, eitherDecode,
16+ encode)
17+import qualified Data.ByteString as BS
18+import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)
19+import Data.String.Conversions (cs)
20+import qualified Data.Text.Lazy as TextL
21+import qualified Data.Text.Lazy.Encoding as TextL
22+import qualified Data.Text as TextS
23+import qualified Data.Text.Encoding as TextS
24+import Data.Typeable
25+import GHC.Exts (Constraint)
26+import qualified Network.HTTP.Media as M
27+
28+-- * Provided content types
29+data JSON deriving Typeable
30+data PlainText deriving Typeable
31+data OctetStream deriving Typeable
32+
33+-- * Accept class
34+
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+--
44+class Accept ctype where
45+ contentType :: Proxy ctype -> M.MediaType
46+
47+-- | @application/json@
48+instance Accept JSON where
49+ contentType _ = "application" M.// "json"
50+
51+-- | @text/plain;charset=utf-8@
52+instance Accept PlainText where
53+ contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
54+
55+-- | @application/octet-stream@
56+instance Accept OctetStream where
57+ contentType _ = "application" M.// "octet-stream"
58+
59+newtype AcceptHeader = AcceptHeader BS.ByteString
60+ deriving (Eq, Show)
61+
62+-- * Render (serializing)
63+
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+--
79+class Accept ctype => MimeRender ctype a where
80+ toByteString :: Proxy ctype -> a -> ByteString
81+
82+class 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)
87+
88+instance ( 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
94+
95+
96+--------------------------------------------------------------------------
97+-- * Unrender
98+
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 => MimeUnrender MyContentType where
108+-- > fromByteString _ bs = MyContentType $ unpack bs
109+-- >
110+-- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int
111+--
112+class Accept ctype => MimeUnrender ctype a where
113+ fromByteString :: Proxy ctype -> ByteString -> Either String a
114+
115+class (IsNonEmpty list) => AllCTUnrender list a where
116+ handleCTypeH :: Proxy list
117+ -> ByteString -- Content-Type header
118+ -> ByteString -- Request body
119+ -> Maybe (Either String a)
120+
121+instance ( 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
125+
126+--------------------------------------------------------------------------
127+-- * Utils (Internal)
128+
129+
130+--------------------------------------------------------------------------
131+-- Check that all elements of list are instances of MimeRender
132+--------------------------------------------------------------------------
133+class AllMimeRender ls a where
134+ allMimeRender :: Proxy ls
135+ -> a -- value to serialize
136+ -> [(M.MediaType, ByteString)] -- content-types/response pairs
137+
138+instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
139+ allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
140+ where pctyp = Proxy :: Proxy ctyp
141+
142+instance ( 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)
149+
150+
151+instance AllMimeRender '[] a where
152+ allMimeRender _ _ = []
153+
154+--------------------------------------------------------------------------
155+-- Check that all elements of list are instances of MimeUnrender
156+--------------------------------------------------------------------------
157+class AllMimeUnrender ls a where
158+ allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
159+
160+instance AllMimeUnrender '[] a where
161+ allMimeUnrender _ _ = []
162+
163+instance ( 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
170+
171+type family IsNonEmpty (ls::[*]) :: Constraint where
172+ IsNonEmpty (x ': xs) = ()
173+
174+
175+--------------------------------------------------------------------------
176+-- * MimeRender Instances
177+
178+-- | `encode`
179+instance ToJSON a => MimeRender JSON a where
180+ toByteString _ = encode
181+
182+-- | `TextL.encodeUtf8`
183+instance MimeRender PlainText TextL.Text where
184+ toByteString _ = TextL.encodeUtf8
185+
186+-- | `fromStrict . TextS.encodeUtf8`
187+instance MimeRender PlainText TextS.Text where
188+ toByteString _ = fromStrict . TextS.encodeUtf8
189+
190+-- | `id`
191+instance MimeRender OctetStream ByteString where
192+ toByteString _ = id
193+
194+-- | `toStrict`
195+instance MimeRender OctetStream BS.ByteString where
196+ toByteString _ = fromStrict
197+
198+
199+--------------------------------------------------------------------------
200+-- * MimeUnrender Instances
201+
202+-- | `eitherDecode`
203+instance FromJSON a => MimeUnrender JSON a where
204+ fromByteString _ = eitherDecode
205+
206+-- | `left show . TextL.decodeUtf8'`
207+instance MimeUnrender PlainText TextL.Text where
208+ fromByteString _ = left show . TextL.decodeUtf8'
209+
210+-- | `left show . TextS.decodeUtf8' . toStrict`
211+instance MimeUnrender PlainText TextS.Text where
212+ fromByteString _ = left show . TextS.decodeUtf8' . toStrict
213+
214+-- | `Right . id`
215+instance MimeUnrender OctetStream ByteString where
216+ fromByteString _ = Right . id
217+
218+-- | `Right . toStrict`
219+instance MimeUnrender OctetStream BS.ByteString where
220+ fromByteString _ = Right . toStrict