]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http/Symantic/HTTP/MIME.hs
stack: bump to lts-14.13
[haskell/symantic-http.git] / symantic-http / Symantic / HTTP / MIME.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE KindSignatures #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 module Symantic.HTTP.MIME where
6
7 import Control.Arrow (left)
8 import Data.Either (Either(..))
9 import Data.Function (($), (.), id)
10 import Data.Foldable (toList)
11 import Data.Functor ((<$>))
12 import Data.Int (Int)
13 import Data.Kind (Constraint)
14 import Data.List.NonEmpty (NonEmpty(..))
15 import Data.Maybe (Maybe(..))
16 import Data.Proxy (Proxy(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.String (String)
19 import Data.Tuple (fst, snd)
20 import Data.Typeable (Typeable)
21 import Text.Read (readMaybe)
22 import Text.Show (Show(..))
23 import qualified Data.ByteString as BS
24 import qualified Data.ByteString.Lazy as BSL
25 import qualified Data.ByteString.Lazy.Char8 as BLC
26 import qualified Data.Text as T
27 import qualified Data.Text.Encoding as T
28 import qualified Data.Text.Lazy as TL
29 import qualified Data.Text.Lazy.Encoding as TL
30 import qualified Network.HTTP.Media as Media
31 import qualified Web.FormUrlEncoded as Web
32
33 -- * Class 'MediaTypeFor'
34 class MediaTypeFor t where
35 mediaTypeFor :: Proxy t -> MediaType
36 mediaTypesFor :: Proxy t -> NonEmpty MediaType
37 mediaTypesFor t = mediaTypeFor t:|[]
38 instance MediaTypeFor () where
39 mediaTypeFor _t = mimeAny
40
41 -- ** Type 'MediaType'
42 type MediaType = Media.MediaType
43 mediaType :: forall t. MediaTypeFor t => MediaType
44 mediaType = mediaTypeFor (Proxy @t)
45 {-# INLINE mediaType #-}
46
47 -- ** Type 'MediaTypes'
48 type MediaTypes = NonEmpty MediaType
49 mediaTypes :: forall ts c. MimeTypes ts c => MediaTypes
50 mediaTypes = fst <$> mimeTypesMap @ts @c
51 {-# INLINE mediaTypes #-}
52
53 charsetUTF8 :: MediaType -> MediaType
54 charsetUTF8 = (Media./: ("charset", "utf-8"))
55
56 mimeAny :: MediaType
57 mimeAny = "*/*"
58
59 -- ** Type 'JSON'
60 data JSON deriving (Typeable)
61 instance MediaTypeFor JSON where
62 mediaTypeFor _t = charsetUTF8 $ "application"Media.//"json"
63 mediaTypesFor t = mediaTypeFor t :| ["application"Media.//"json"]
64
65 -- ** Type 'HTML'
66 data HTML deriving (Typeable)
67 instance MediaTypeFor HTML where
68 mediaTypeFor _t = charsetUTF8 $ "text"Media.//"html"
69 mediaTypesFor t = mediaTypeFor t :| ["text"Media.//"html"]
70
71 -- ** Type 'FormUrlEncoded'
72 data FormUrlEncoded deriving (Typeable)
73 instance MediaTypeFor FormUrlEncoded where
74 mediaTypeFor _t = "application"Media.//"x-www-form-urlencoded"
75
76 -- ** Type 'OctetStream'
77 data OctetStream deriving (Typeable)
78 instance MediaTypeFor OctetStream where
79 mediaTypeFor _t = "application"Media.//"octet-stream"
80
81 -- ** Type 'PlainText'
82 data PlainText deriving (Typeable)
83 instance MediaTypeFor PlainText where
84 mediaTypeFor _t = charsetUTF8 $ "text"Media.//"plain"
85
86 -- * Type 'MimeType'
87 -- | Existentially wraps a type-level type 't'
88 -- with a proof it respects 'Constraint' 'c'.
89 -- Usyally 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@.
90 data MimeType c where
91 MimeType :: (c t, MediaTypeFor t) => Proxy t -> MimeType c
92 mimeType :: forall t c. MediaTypeFor t => c t => MimeType c
93 mimeType = MimeType (Proxy @t)
94 {-# INLINE mimeType #-}
95
96 -- ** Type 'MimeTypeTs'
97 type MimeTypeTs c = NonEmpty (MimeType c)
98 mimeTypes :: forall ts c. MimeTypes ts c => NonEmpty (MimeType c)
99 mimeTypes = snd <$> mimeTypesMap @ts @c
100 {-# INLINE mimeTypes #-}
101
102 -- * Class 'MimeTypes'
103 -- | Implicitely generate 'MediaType's and 'MimeType's
104 -- from given type-level list of types.
105 class MimeTypes (ts::[*]) (c:: * -> Constraint) where
106 mimeTypesMap :: NonEmpty (MediaType, MimeType c)
107 -- | Single 'MimeType'.
108 instance
109 (MediaTypeFor t, c t) =>
110 MimeTypes '[t] c where
111 mimeTypesMap =
112 (, MimeType @c @t Proxy)
113 <$> mediaTypesFor (Proxy @t)
114 -- | More than one 'MimeType'.
115 instance
116 ( MediaTypeFor t
117 , MimeTypes (t1 ':ts) c
118 , c t
119 ) =>
120 MimeTypes (t ': t1 ': ts) c where
121 mimeTypesMap =
122 ((, MimeType @c @t Proxy)
123 <$> mediaTypesFor (Proxy @t))
124 <> mimeTypesMap @(t1 ':ts) @c
125
126 matchAccept ::
127 forall ts c. MimeTypes ts c =>
128 BS.ByteString -> Maybe (MimeType c)
129 matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
130
131 matchContent ::
132 forall ts c. MimeTypes ts c =>
133 BS.ByteString -> Maybe (MimeType c)
134 matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
135
136 -- * Type 'MimeEncodable'
137 class MediaTypeFor t => MimeEncodable a t where
138 mimeEncode :: Proxy t -> MimeEncoder a
139 instance MimeEncodable () PlainText where
140 mimeEncode _ () = BLC.pack ""
141 -- | @BSL.fromStrict . T.encodeUtf8@
142 instance MimeEncodable String PlainText where
143 mimeEncode _ = BLC.pack
144 instance MimeEncodable T.Text PlainText where
145 mimeEncode _ = BSL.fromStrict . T.encodeUtf8
146 instance MimeEncodable TL.Text PlainText where
147 mimeEncode _ = TL.encodeUtf8
148 instance MimeEncodable BS.ByteString OctetStream where
149 mimeEncode _ = BSL.fromStrict
150 instance MimeEncodable BSL.ByteString OctetStream where
151 mimeEncode _ = id
152 instance MimeEncodable Int PlainText where
153 mimeEncode _ = TL.encodeUtf8 . TL.pack . show
154 -- | @Web.urlEncodeAsForm@
155 -- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
156 -- holds if every element of x is non-null (i.e., not @("", "")@)
157 instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
158 mimeEncode _ = Web.urlEncodeAsForm
159 {-
160 -- | `encode`
161 instance {-# OVERLAPPABLE #-}
162 ToJSON a => MimeEncodable JSON a where
163 mimeEncode _ = encode
164 -}
165
166 -- ** Type 'MimeEncoder'
167 type MimeEncoder a = a -> BSL.ByteString
168
169 -- * Type 'MimeDecodable'
170 class MediaTypeFor mt => MimeDecodable a mt where
171 mimeDecode :: Proxy mt -> MimeDecoder a
172 -- mimeDecode p = mimeUnserializeWithType p (mimeType p)
173
174 -- ** Type 'MimeDecoder'
175 type MimeDecoder a = BSL.ByteString -> Either String a
176
177 instance MimeDecodable () PlainText where
178 mimeDecode _ bsl =
179 if BLC.null bsl
180 then Right ()
181 else Left "not empty"
182 instance MimeDecodable String PlainText where
183 mimeDecode _ = Right . BLC.unpack
184 instance MimeDecodable T.Text PlainText where
185 mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
186 instance MimeDecodable TL.Text PlainText where
187 mimeDecode _ = left show . TL.decodeUtf8'
188 instance MimeDecodable BS.ByteString OctetStream where
189 mimeDecode _ = Right . BSL.toStrict
190 instance MimeDecodable BSL.ByteString OctetStream where
191 mimeDecode _ = Right
192 instance MimeDecodable Int PlainText where
193 mimeDecode _mt bsl =
194 let s = TL.unpack $ TL.decodeUtf8 bsl in
195 case readMaybe s of
196 Just n -> Right n
197 _ -> Left $ "cannot parse as Int: "<>s
198 -- | @Web.urlDecodeAsForm@
199 -- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
200 -- holds if every element of x is non-null (i.e., not @("", "")@)
201 instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
202 mimeDecode _ = left T.unpack . Web.urlDecodeAsForm
203 {-
204 -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
205 -- objects and arrays.
206 --
207 -- Will handle trailing whitespace, but not trailing junk. ie.
208 --
209 -- >>> eitherDecodeLenient "1 " :: Either String Int
210 -- Right 1
211 --
212 -- >>> eitherDecodeLenient "1 junk" :: Either String Int
213 -- Left "trailing junk after valid JSON: endOfInput"
214 eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
215 eitherDecodeLenient input =
216 parseOnly parser (cs input) >>= parseEither parseJSON
217 where
218 parser = skipSpace
219 *> Data.Aeson.Parser.value
220 <* skipSpace
221 <* (endOfInput <?> "trailing junk after valid JSON")
222
223 -- | `eitherDecode`
224 instance FromJSON a => MimeDecodable JSON a where
225 mimeDecode _ = eitherDecodeLenient
226 -}