1 module Symantic.HTTP.Mime where
3 -- import qualified Data.List.NonEmpty as NE
4 import Control.Arrow (left)
5 import Data.Either (Either(..))
6 import Data.Function ((.), id)
7 import Data.Proxy (Proxy(..))
8 import Data.String (String)
9 import Text.Show (Show(..))
10 import qualified Data.ByteString as BS
11 import qualified Data.ByteString.Lazy as BSL
12 import qualified Data.ByteString.Lazy.Char8 as BLC
13 import qualified Data.Text as T
14 import qualified Data.Text.Encoding as T
15 import qualified Data.Text.Lazy as TL
16 import qualified Data.Text.Lazy.Encoding as TL
17 -- import qualified Network.HTTP.Media as Media
18 import qualified Web.FormUrlEncoded as Web
19 import Symantic.HTTP.Media
23 data MimeType mt a where
27 MimeUnserialize mt a =>
30 mimeType :: MediaType -> MimeType mt
34 newtype AcceptHeader = AcceptHeader BS.ByteString
35 deriving (Eq, Show, Read, Typeable, Generic)
38 -- * Type 'MimeSerialize'
39 class MediaTypeable mt => MimeSerialize mt a where
40 mimeSerialize :: Proxy mt -> Serializer a
41 -- | @BSL.fromStrict . T.encodeUtf8@
42 instance MimeSerialize PlainText String where
43 mimeSerialize _ = BLC.pack
44 instance MimeSerialize PlainText T.Text where
45 mimeSerialize _ = BSL.fromStrict . T.encodeUtf8
46 instance MimeSerialize PlainText TL.Text where
47 mimeSerialize _ = TL.encodeUtf8
48 instance MimeSerialize OctetStream BS.ByteString where
49 mimeSerialize _ = BSL.fromStrict
50 instance MimeSerialize OctetStream BSL.ByteString where
52 -- | @Web.urlEncodeAsForm@
53 -- Note that the @mimeUnserialize p (mimeSerialize p x) == Right x@ law only
54 -- holds if every element of x is non-null (i.e., not @("", "")@)
55 instance Web.ToForm a => MimeSerialize FormUrlEncoded a where
56 mimeSerialize _ = Web.urlEncodeAsForm
59 instance {-# OVERLAPPABLE #-}
60 ToJSON a => MimeSerialize JSON a where
61 mimeSerialize _ = encode
64 -- ** Type 'Serializer'
65 type Serializer a = a -> BSL.ByteString
68 class (AllMime list) => AllCTSerialize (list :: [*]) a where
69 -- If the Accept header can be matched, returns (Just) a tuple of the
70 -- Content-Type and response (serialization of @a@ into the appropriate
72 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
74 instance {-# OVERLAPPABLE #-}
75 (Accept ct, AllMime cts, AllMimeSerialize (ct ': cts) a) => AllCTSerialize (ct ': cts) a where
76 handleAcceptH _ (AcceptHeader accept) val = Media.mapAcceptMedia lkup accept
78 pctyps = Proxy :: Proxy (ct ': cts)
79 amrs = allMimeSerialize pctyps val
80 lkup = fmap (\(a,b) -> (a, (BSL.fromStrict $ Media.renderHeader a, b))) amrs
82 instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTSerialize '[] () where
83 handleAcceptH _ _ _ = error "unreachable"
86 -- * Type 'MimeUnserialize'
87 class MediaTypeable mt => MimeUnserialize mt a where
88 mimeUnserialize :: Proxy mt -> Unserializer a
89 -- mimeUnserialize p = mimeUnserializeWithType p (mediaType p)
92 -- | Variant which is given the actual 'Media.MediaType' provided by the other party.
94 -- In the most cases you don't want to branch based on the 'Media.MediaType'.
95 -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
96 mimeUnserializeWithType :: Proxy mt -> Media.MediaType -> Unserializer a
97 mimeUnserializeWithType p _ = mimeUnserialize p
98 {-# MINIMAL mimeUnserialize | mimeUnserializeWithType #-}
100 instance MimeUnserialize PlainText String where
101 mimeUnserialize _ = Right . BLC.unpack
102 instance MimeUnserialize PlainText T.Text where
103 mimeUnserialize _ = left show . T.decodeUtf8' . BSL.toStrict
104 instance MimeUnserialize PlainText TL.Text where
105 mimeUnserialize _ = left show . TL.decodeUtf8'
106 instance MimeUnserialize OctetStream BS.ByteString where
107 mimeUnserialize _ = Right . BSL.toStrict
108 instance MimeUnserialize OctetStream BSL.ByteString where
109 mimeUnserialize _ = Right
110 -- | @Web.urlDecodeAsForm@
111 -- Note that the @mimeUnserialize p (mimeSerialize p x) == Right x@ law only
112 -- holds if every element of x is non-null (i.e., not @("", "")@)
113 instance Web.FromForm a => MimeUnserialize FormUrlEncoded a where
114 mimeUnserialize _ = left T.unpack . Web.urlDecodeAsForm
116 -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
117 -- objects and arrays.
119 -- Will handle trailing whitespace, but not trailing junk. ie.
121 -- >>> eitherDecodeLenient "1 " :: Either String Int
124 -- >>> eitherDecodeLenient "1 junk" :: Either String Int
125 -- Left "trailing junk after valid JSON: endOfInput"
126 eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
127 eitherDecodeLenient input =
128 parseOnly parser (cs input) >>= parseEither parseJSON
131 *> Data.Aeson.Parser.value
133 <* (endOfInput <?> "trailing junk after valid JSON")
136 instance FromJSON a => MimeUnserialize JSON a where
137 mimeUnserialize _ = eitherDecodeLenient
139 -- ** Type 'Unserializer'
140 type Unserializer a = BSL.ByteString -> Either String a
155 -- | A type for responses without content-body.
156 data NoContent = NoContent
161 class AllCTUnserialize (list :: [*]) a where
164 -> ByteString -- Content-Type header
165 -> Maybe (ByteString -> Either String a)
167 handleCTypeH :: Proxy list
168 -> ByteString -- Content-Type header
169 -> ByteString -- Request body
170 -> Maybe (Either String a)
171 handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
173 instance ( AllMimeUnserialize ctyps a ) => AllCTUnserialize ctyps a where
174 canHandleCTypeH p ctypeH =
175 Media.mapContentMedia (allMimeUnserialize p) (cs ctypeH)
177 --------------------------------------------------------------------------
178 -- * Utils (Internal)
180 class AllMime (list :: [*]) where
181 allMime :: Proxy list -> [Media.MediaType]
183 instance AllMime '[] where
186 instance (MediaType ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
187 allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
189 pctyp = Proxy :: Proxy ctyp
190 pctyps = Proxy :: Proxy ctyps
192 canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
193 canHandleAcceptH p (AcceptHeader h ) = isJust $ Media.matchAccept (allMime p) h
195 --------------------------------------------------------------------------
196 -- Check that all elements of list are instances of MimeSerialize
197 --------------------------------------------------------------------------
198 class (AllMime list) => AllMimeSerialize (list :: [*]) a where
199 allMimeSerialize :: Proxy list
200 -> a -- value to serialize
201 -> [(Media.MediaType, ByteString)] -- content-types/response pairs
203 instance {-# OVERLAPPABLE #-} ( MimeSerialize ctyp a ) => AllMimeSerialize '[ctyp] a where
204 allMimeSerialize _ a = map (, bs) $ NE.toList $ contentTypes pctyp
206 bs = mimeSerialize pctyp a
207 pctyp = Proxy :: Proxy ctyp
209 instance {-# OVERLAPPABLE #-}
210 ( MimeSerialize ctyp a
211 , AllMimeSerialize (ctyp' ': ctyps) a
212 ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) a where
213 allMimeSerialize _ a =
214 map (, bs) (NE.toList $ contentTypes pctyp)
215 ++ allMimeSerialize pctyps a
217 bs = mimeSerialize pctyp a
218 pctyp = Proxy :: Proxy ctyp
219 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
222 -- Ideally we would like to declare a 'MimeSerialize a NoContent' instance, and
223 -- then this would be taken care of. However there is no more specific instance
224 -- between that and 'MimeSerialize JSON a', so we do this instead
225 instance {-# OVERLAPPING #-} ( MediaType ctyp ) => AllMimeSerialize '[ctyp] NoContent where
226 allMimeSerialize _ _ = map (, "") $ NE.toList $ contentTypes pctyp
228 pctyp = Proxy :: Proxy ctyp
230 instance {-# OVERLAPPING #-}
231 ( AllMime (ctyp ': ctyp' ': ctyps)
232 ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) NoContent where
233 allMimeSerialize p _ = zip (allMime p) (repeat "")
235 --------------------------------------------------------------------------
236 -- Check that all elements of list are instances of MimeUnserialize
237 --------------------------------------------------------------------------
238 class (AllMime list) => AllMimeUnserialize (list :: [*]) a where
239 allMimeUnserialize :: Proxy list
240 -> [(Media.MediaType, ByteString -> Either String a)]
241 instance AllMimeUnserialize '[] a where
242 allMimeUnserialize _ = []
243 instance ( MimeUnserialize ctyp a
244 , AllMimeUnserialize ctyps a
245 ) => AllMimeUnserialize (ctyp ': ctyps) a where
246 allMimeUnserialize _ =
247 map mk (NE.toList $ contentTypes pctyp)
248 ++ allMimeUnserialize pctyps
250 mk ct = (ct, mimeUnserializeWithType pctyp ct)
251 pctyp = Proxy :: Proxy ctyp
252 pctyps = Proxy :: Proxy ctyps