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