1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE ConstraintKinds #-}
4 {-# LANGUAGE KindSignatures #-}
5 {-# LANGUAGE OverloadedStrings #-}
7 module Literate.Web.Types.MIME where
9 import Control.Arrow (left)
11 import Data.ByteString qualified as BS
12 import Data.ByteString.Lazy qualified as BSL
13 import Data.ByteString.Lazy.Char8 qualified as BLC
14 import Data.Either (Either (..))
15 import Data.Eq (Eq (..))
16 import Data.Foldable (toList)
17 import Data.Function (id, ($), (.))
18 import Data.Functor ((<$>))
20 import Data.Kind (Constraint, Type)
21 import Data.List.NonEmpty (NonEmpty (..))
22 import Data.Maybe (Maybe (..), isJust)
23 import Data.Proxy (Proxy (..))
24 import Data.Semigroup (Semigroup (..))
25 import Data.String (String)
26 import Data.Text qualified as T
27 import Data.Text.Encoding qualified as T
28 import Data.Text.Lazy qualified as TL
29 import Data.Text.Lazy.Encoding qualified as TL
30 import Data.Tuple (fst, snd)
31 import Data.Typeable (Typeable, eqT)
32 import Network.HTTP.Media qualified as Media
33 import Text.Read (readMaybe)
34 import Text.Show (Show (..))
36 --import qualified Web.FormUrlEncoded as Web
38 -- * Class 'FileExtension'
39 class FileExtension fmt where
40 fileExtension :: T.Text
42 -- * Class 'MediaTypeFor'
43 class (Typeable fmt, FileExtension fmt) => MediaTypeFor fmt where
44 mediaTypeFor :: Proxy fmt -> MediaType
45 mediaTypesFor :: Proxy fmt -> NonEmpty MediaType
46 mediaTypesFor fmt = mediaTypeFor fmt :| []
47 instance MediaTypeFor () where
48 mediaTypeFor _t = mimeAny
49 instance FileExtension () where
52 -- ** Type 'MediaType'
53 type MediaType = Media.MediaType
54 mediaType :: forall fmt. MediaTypeFor fmt => MediaType
55 mediaType = mediaTypeFor (Proxy @fmt)
56 {-# INLINE mediaType #-}
58 -- ** Type 'MediaTypes'
59 type MediaTypes = NonEmpty MediaType
60 mediaTypes :: forall ts c. MimeTypes ts c => MediaTypes
61 mediaTypes = fst <$> mimeTypesMap @ts @c
62 {-# INLINE mediaTypes #-}
64 charsetUTF8 :: MediaType -> MediaType
65 charsetUTF8 = (Media./: ("charset", "utf-8"))
71 data JSON deriving (Typeable)
72 instance MediaTypeFor JSON where
73 mediaTypeFor _t = charsetUTF8 $ "application" Media.// "json"
74 mediaTypesFor fmt = mediaTypeFor fmt :| ["application" Media.// "json"]
75 instance FileExtension JSON where
76 fileExtension = "json"
79 data HTML deriving (Typeable)
80 instance MediaTypeFor HTML where
81 mediaTypeFor _t = charsetUTF8 $ "text" Media.// "html"
82 mediaTypesFor fmt = mediaTypeFor fmt :| ["text" Media.// "html"]
83 instance FileExtension HTML where
84 fileExtension = "html"
86 -- ** Type 'FormUrlEncoded'
87 data FormUrlEncoded deriving (Typeable)
88 instance MediaTypeFor FormUrlEncoded where
89 mediaTypeFor _t = "application" Media.// "x-www-form-urlencoded"
90 instance FileExtension FormUrlEncoded where
93 -- ** Type 'OctetStream'
94 data OctetStream deriving (Typeable)
95 instance MediaTypeFor OctetStream where
96 mediaTypeFor _t = "application" Media.// "octet-stream"
97 instance FileExtension OctetStream where
100 -- ** Type 'PlainText'
101 data PlainText deriving (Typeable)
102 instance MediaTypeFor PlainText where
103 mediaTypeFor _t = charsetUTF8 $ "text" Media.// "plain"
104 instance FileExtension PlainText where
105 fileExtension = "txt"
109 -- | Existentially wraps a type-level type 'fmt'
110 -- with a proof it respects 'Constraint' 'c'.
111 -- Usually 'c' is 'MimeEncodable' or 'MimeDecodable'.
112 data MimeType c where
113 MimeType :: (c fmt, MediaTypeFor fmt) => Proxy fmt -> MimeType c
115 instance Eq (MimeType c) where
116 MimeType (_ :: Proxy x) == MimeType (_ :: Proxy y) = isJust (eqT @x @y)
118 mimeType :: forall fmt c. MediaTypeFor fmt => c fmt => MimeType c
119 mimeType = MimeType (Proxy @fmt)
120 {-# INLINE mimeType #-}
121 mimeTypes :: forall ts c. MimeTypes ts c => NonEmpty (MimeType c)
122 mimeTypes = snd <$> mimeTypesMap @ts @c
123 {-# INLINE mimeTypes #-}
125 -- * Class 'MimeTypes'
127 -- | Implicitely generate 'MediaType's and 'MimeType's
128 -- from a type-level list of types.
129 class MimeTypes (ts :: [Type]) (c :: Type -> Constraint) where
130 mimeTypesMap :: NonEmpty (MediaType, MimeType c)
132 instance (MediaTypeFor fmt, c fmt) => MimeTypes '[fmt] c where
133 mimeTypesMap = (,MimeType @c @fmt Proxy) <$> mediaTypesFor (Proxy @fmt)
134 instance (MediaTypeFor fmt, MimeTypes (t1 ': ts) c, c fmt) => MimeTypes (fmt ': t1 ': ts) c where
136 ( (,MimeType @c @fmt Proxy)
137 <$> mediaTypesFor (Proxy @fmt)
139 <> mimeTypesMap @(t1 ': ts) @c
146 matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
153 matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
155 -- * Type 'MimeEncodable'
156 class MediaTypeFor fmt => MimeEncodable a fmt where
157 mimeEncode :: MimeEncoder a
158 instance MimeEncodable () PlainText where
159 mimeEncode () = BLC.pack ""
161 -- | @BSL.fromStrict . T.encodeUtf8@
162 instance MimeEncodable String PlainText where
163 mimeEncode = BLC.pack
165 instance MimeEncodable T.Text PlainText where
166 mimeEncode = BSL.fromStrict . T.encodeUtf8
167 instance MimeEncodable TL.Text PlainText where
168 mimeEncode = TL.encodeUtf8
169 instance MimeEncodable BS.ByteString OctetStream where
170 mimeEncode = BSL.fromStrict
171 instance MimeEncodable BSL.ByteString OctetStream where
173 instance MimeEncodable Int PlainText where
174 mimeEncode = TL.encodeUtf8 . TL.pack . show
176 -- | @Web.urlEncodeAsForm@
177 -- Note that the @mimeDecode @_ @fmt (mimeEncode @_ @fmt x) == Right x@ law only
178 -- holds if every element of x is non-null (i.e., not @("", "")@)
179 --instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
180 -- mimeEncode _ = Web.urlEncodeAsForm
182 -- ** Type 'MimeEncoder'
184 type MimeEncoder a = a -> BSL.ByteString
186 -- * Type 'MimeDecodable'
187 class MediaTypeFor mt => MimeDecodable a mt where
188 mimeDecode :: Proxy mt -> MimeDecoder a
190 -- mimeDecode p = mimeUnserializeWithType p (mimeType p)
192 -- ** Type 'MimeDecoder'
193 type MimeDecoder a = BSL.ByteString -> Either String a
195 instance MimeDecodable () PlainText where
197 | BLC.null bsl = Right ()
198 | otherwise = Left "not empty"
199 instance MimeDecodable String PlainText where
200 mimeDecode _ = Right . BLC.unpack
201 instance MimeDecodable T.Text PlainText where
202 mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
203 instance MimeDecodable TL.Text PlainText where
204 mimeDecode _ = left show . TL.decodeUtf8'
205 instance MimeDecodable BS.ByteString OctetStream where
206 mimeDecode _ = Right . BSL.toStrict
207 instance MimeDecodable BSL.ByteString OctetStream where
209 instance MimeDecodable Int PlainText where
213 _ -> Left $ "cannot parse as Int: " <> s
215 s = TL.unpack (TL.decodeUtf8 bsl)
217 -- | @Web.urlDecodeAsForm@
218 -- Note that the @mimeDecode @_ @fmt (mimeEncode @_ @fmt x) == Right x@ law only
219 -- holds if every element of x is non-null (i.e., not @("", "")@)
220 --instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
221 -- mimeDecode _ = left T.unpack . Web.urlDecodeAsForm