]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/Mime.hs
Replace megaparsec with a custom parser
[haskell/symantic-http.git] / Symantic / HTTP / Mime.hs
1 module Symantic.HTTP.Mime where
2
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
20
21 {-
22 -- * Type 'MimeType'
23 data MimeType mt a where
24 MimeType ::
25 forall mt.
26 MimeSerialize mt a =>
27 MimeUnserialize mt a =>
28 MimeType mt a
29
30 mimeType :: MediaType -> MimeType mt
31 -}
32
33 {-
34 newtype AcceptHeader = AcceptHeader BS.ByteString
35 deriving (Eq, Show, Read, Typeable, Generic)
36 -}
37
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
51 mimeSerialize _ = id
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
57 {-
58 -- | `encode`
59 instance {-# OVERLAPPABLE #-}
60 ToJSON a => MimeSerialize JSON a where
61 mimeSerialize _ = encode
62 -}
63
64 -- ** Type 'Serializer'
65 type Serializer a = a -> BSL.ByteString
66
67 {-
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
71 -- mimetype).
72 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
73
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
77 where
78 pctyps = Proxy :: Proxy (ct ': cts)
79 amrs = allMimeSerialize pctyps val
80 lkup = fmap (\(a,b) -> (a, (BSL.fromStrict $ Media.renderHeader a, b))) amrs
81
82 instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTSerialize '[] () where
83 handleAcceptH _ _ _ = error "unreachable"
84 -}
85
86 -- * Type 'MimeUnserialize'
87 class MediaTypeable mt => MimeUnserialize mt a where
88 mimeUnserialize :: Proxy mt -> Unserializer a
89 -- mimeUnserialize p = mimeUnserializeWithType p (mediaType p)
90
91 {-
92 -- | Variant which is given the actual 'Media.MediaType' provided by the other party.
93 --
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 #-}
99 -}
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
115 {-
116 -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
117 -- objects and arrays.
118 --
119 -- Will handle trailing whitespace, but not trailing junk. ie.
120 --
121 -- >>> eitherDecodeLenient "1 " :: Either String Int
122 -- Right 1
123 --
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
129 where
130 parser = skipSpace
131 *> Data.Aeson.Parser.value
132 <* skipSpace
133 <* (endOfInput <?> "trailing junk after valid JSON")
134
135 -- | `eitherDecode`
136 instance FromJSON a => MimeUnserialize JSON a where
137 mimeUnserialize _ = eitherDecodeLenient
138 -}
139 -- ** Type 'Unserializer'
140 type Unserializer a = BSL.ByteString -> Either String a
141
142
143
144
145
146
147
148
149
150
151
152
153
154 {-
155 -- | A type for responses without content-body.
156 data NoContent = NoContent
157 deriving (Show, Eq)
158
159
160
161 class AllCTUnserialize (list :: [*]) a where
162 canHandleCTypeH
163 :: Proxy list
164 -> ByteString -- Content-Type header
165 -> Maybe (ByteString -> Either String a)
166
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
172
173 instance ( AllMimeUnserialize ctyps a ) => AllCTUnserialize ctyps a where
174 canHandleCTypeH p ctypeH =
175 Media.mapContentMedia (allMimeUnserialize p) (cs ctypeH)
176
177 --------------------------------------------------------------------------
178 -- * Utils (Internal)
179
180 class AllMime (list :: [*]) where
181 allMime :: Proxy list -> [Media.MediaType]
182
183 instance AllMime '[] where
184 allMime _ = []
185
186 instance (MediaType ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
187 allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
188 where
189 pctyp = Proxy :: Proxy ctyp
190 pctyps = Proxy :: Proxy ctyps
191
192 canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
193 canHandleAcceptH p (AcceptHeader h ) = isJust $ Media.matchAccept (allMime p) h
194
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
202
203 instance {-# OVERLAPPABLE #-} ( MimeSerialize ctyp a ) => AllMimeSerialize '[ctyp] a where
204 allMimeSerialize _ a = map (, bs) $ NE.toList $ contentTypes pctyp
205 where
206 bs = mimeSerialize pctyp a
207 pctyp = Proxy :: Proxy ctyp
208
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
216 where
217 bs = mimeSerialize pctyp a
218 pctyp = Proxy :: Proxy ctyp
219 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
220
221
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
227 where
228 pctyp = Proxy :: Proxy ctyp
229
230 instance {-# OVERLAPPING #-}
231 ( AllMime (ctyp ': ctyp' ': ctyps)
232 ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) NoContent where
233 allMimeSerialize p _ = zip (allMime p) (repeat "")
234
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
249 where
250 mk ct = (ct, mimeUnserializeWithType pctyp ct)
251 pctyp = Proxy :: Proxy ctyp
252 pctyps = Proxy :: Proxy ctyps
253 -}
254
255
256