src/Literate/Web/Types/MIME.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE KindSignatures #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6
   7 module Literate.Web.Types.MIME where
   8
   9 import Control.Arrow (left)
  10 import Data.Bool
  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 ((<$>))
  19 import Data.Int (Int)
  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 (..))
  35
  36 --import qualified Web.FormUrlEncoded as Web
  37
  38 -- * Class 'FileExtension'
  39 class FileExtension fmt where
  40   fileExtension :: T.Text
  41
  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
  50   fileExtension = ""
  51
  52 -- ** Type 'MediaType'
  53 type MediaType = Media.MediaType
  54 mediaType :: forall fmt. MediaTypeFor fmt => MediaType
  55 mediaType = mediaTypeFor (Proxy @fmt)
  56 {-# INLINE mediaType #-}
  57
  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 #-}
  63
  64 charsetUTF8 :: MediaType -> MediaType
  65 charsetUTF8 = (Media./: ("charset", "utf-8"))
  66
  67 mimeAny :: MediaType
  68 mimeAny = "*/*"
  69
  70 -- ** Type 'JSON'
  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"
  77
  78 -- ** Type 'HTML'
  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"
  85
  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
  91   fileExtension = "url"
  92
  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
  98   fileExtension = "bin"
  99
 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"
 106
 107 -- * Type 'MimeType'
 108
 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
 114
 115 instance Eq (MimeType c) where
 116   MimeType (_ :: Proxy x) == MimeType (_ :: Proxy y) = isJust (eqT @x @y)
 117
 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 #-}
 124
 125 -- * Class 'MimeTypes'
 126
 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)
 131
 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
 135   mimeTypesMap =
 136     ( (,MimeType @c @fmt Proxy)
 137         <$> mediaTypesFor (Proxy @fmt)
 138     )
 139       <> mimeTypesMap @(t1 ': ts) @c
 140
 141 matchAccept ::
 142   forall ts c.
 143   MimeTypes ts c =>
 144   BS.ByteString ->
 145   Maybe (MimeType c)
 146 matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
 147
 148 matchContent ::
 149   forall ts c.
 150   MimeTypes ts c =>
 151   BS.ByteString ->
 152   Maybe (MimeType c)
 153 matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
 154
 155 -- * Type 'MimeEncodable'
 156 class MediaTypeFor fmt => MimeEncodable a fmt where
 157   mimeEncode :: MimeEncoder a
 158 instance MimeEncodable () PlainText where
 159   mimeEncode () = BLC.pack ""
 160
 161 -- | @BSL.fromStrict . T.encodeUtf8@
 162 instance MimeEncodable String PlainText where
 163   mimeEncode = BLC.pack
 164
 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
 172   mimeEncode = id
 173 instance MimeEncodable Int PlainText where
 174   mimeEncode = TL.encodeUtf8 . TL.pack . show
 175
 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
 181
 182 -- ** Type 'MimeEncoder'
 183
 184 type MimeEncoder a = a -> BSL.ByteString
 185
 186 -- * Type 'MimeDecodable'
 187 class MediaTypeFor mt => MimeDecodable a mt where
 188   mimeDecode :: Proxy mt -> MimeDecoder a
 189
 190 -- mimeDecode p = mimeUnserializeWithType p (mimeType p)
 191
 192 -- ** Type 'MimeDecoder'
 193 type MimeDecoder a = BSL.ByteString -> Either String a
 194
 195 instance MimeDecodable () PlainText where
 196   mimeDecode _ bsl
 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
 208   mimeDecode _ = Right
 209 instance MimeDecodable Int PlainText where
 210   mimeDecode _mt bsl =
 211     case readMaybe s of
 212       Just n -> Right n
 213       _ -> Left $ "cannot parse as Int: " <> s
 214     where
 215       s = TL.unpack (TL.decodeUtf8 bsl)
 216
 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