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.Builder qualified as BSB
  13 import Data.ByteString.Lazy qualified as BSL
  14 import Data.ByteString.Lazy.Char8 qualified as BLC
  15 import Data.Either (Either (..))
  16 import Data.Eq (Eq (..))
  17 import Data.Foldable (toList)
  18 import Data.Function (($), (.))
  19 import Data.Functor ((<$>))
  20 import Data.Int (Int)
  21 import Data.Kind (Constraint, Type)
  22 import Data.List.NonEmpty (NonEmpty (..), (<|))
  23 import Data.Maybe (Maybe (..), isJust, maybe)
  24 import Data.Monoid (Monoid (..))
  25 import Data.Proxy (Proxy (..))
  26 import Data.Semigroup (Semigroup (..))
  27 import Data.String (String)
  28 import Data.Text qualified as T
  29 import Data.Text.Encoding qualified as T
  30 import Data.Text.Lazy qualified as TL
  31 import Data.Text.Lazy.Encoding qualified as TL
  32 import Data.Text.Short qualified as ST
  33 import Data.Tuple (fst, snd)
  34 import Data.Typeable (Typeable, eqT)
  35 import Network.HTTP.Media qualified as Media
  36 import Text.Read (readMaybe)
  37 import Text.Show (Show (..))
  38
  39 -- import qualified Web.FormUrlEncoded as Web
  40
  41 -- * Class 'FileExtension'
  42 class FileExtension fmt where
  43   fileExtension :: T.Text
  44
  45 -- * Class 'MediaTypeFor'
  46 class (Typeable fmt, FileExtension fmt) => MediaTypeFor fmt where
  47   mediaTypeFor :: Proxy fmt -> MediaType
  48 instance MediaTypeFor () where
  49   mediaTypeFor _t = mimeAny
  50 instance FileExtension () where
  51   fileExtension = ""
  52
  53 -- ** Type 'MediaType'
  54 type MediaType = Media.MediaType
  55 mediaType :: forall fmt. MediaTypeFor fmt => MediaType
  56 mediaType = mediaTypeFor (Proxy @fmt)
  57 {-# INLINE mediaType #-}
  58
  59 -- ** Type 'MediaTypes'
  60 type MediaTypes = NonEmpty MediaType
  61 mediaTypes :: forall ts c. MimeTypes ts c => MediaTypes
  62 mediaTypes = fst <$> mimeTypesMap @ts @c
  63 {-# INLINE mediaTypes #-}
  64
  65 charsetUTF8 :: MediaType -> MediaType
  66 charsetUTF8 = (Media./: ("charset", "utf-8"))
  67
  68 mimeAny :: MediaType
  69 mimeAny = "*/*"
  70
  71 -- ** Type 'JSON'
  72 data JSON deriving (Typeable)
  73 instance MediaTypeFor JSON where
  74   mediaTypeFor _t = charsetUTF8 $ "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 instance FileExtension HTML where
  83   fileExtension = "html"
  84
  85 -- ** Type 'FormUrlEncoded'
  86 data FormUrlEncoded deriving (Typeable)
  87 instance MediaTypeFor FormUrlEncoded where
  88   mediaTypeFor _t = "application" Media.// "x-www-form-urlencoded"
  89 instance FileExtension FormUrlEncoded where
  90   fileExtension = "url"
  91
  92 -- ** Type 'OctetStream'
  93 data OctetStream deriving (Typeable)
  94 instance MediaTypeFor OctetStream where
  95   mediaTypeFor _t = "application" Media.// "octet-stream"
  96 instance FileExtension OctetStream where
  97   fileExtension = "bin"
  98
  99 -- ** Type 'PlainText'
 100 data PlainText deriving (Typeable)
 101 instance MediaTypeFor PlainText where
 102   mediaTypeFor _t = charsetUTF8 $ "text" Media.// "plain"
 103 instance FileExtension PlainText where
 104   fileExtension = "txt"
 105
 106 -- * Type 'MimeType'
 107
 108 -- | Existentially wraps a type-level type 'fmt'
 109 -- with a proof it respects 'Constraint' 'c'.
 110 -- Usually 'c' is 'MimeEncodable' or 'MimeDecodable'.
 111 data MimeType c where
 112   MimeType :: (c fmt, MediaTypeFor fmt) => Proxy fmt -> MimeType c
 113
 114 instance Eq (MimeType c) where
 115   MimeType (_ :: Proxy x) == MimeType (_ :: Proxy y) = isJust (eqT @x @y)
 116
 117 mimeType :: forall fmt c. MediaTypeFor fmt => c fmt => MimeType c
 118 mimeType = MimeType (Proxy @fmt)
 119 {-# INLINE mimeType #-}
 120 mimeTypes :: forall ts c. MimeTypes ts c => NonEmpty (MimeType c)
 121 mimeTypes = snd <$> mimeTypesMap @ts @c
 122 {-# INLINE mimeTypes #-}
 123
 124 -- * Class 'MimeTypes'
 125
 126 -- | Implicitely generate 'MediaType's and 'MimeType's
 127 -- from a type-level list of types.
 128 class MimeTypes (ts :: [Type]) (c :: Type -> Constraint) where
 129   mimeTypesMap :: NonEmpty (MediaType, MimeType c)
 130
 131 instance (MediaTypeFor fmt, c fmt) => MimeTypes '[fmt] c where
 132   mimeTypesMap = (mediaTypeFor (Proxy @fmt), MimeType @c @fmt Proxy) :| []
 133 instance (MediaTypeFor fmt, MimeTypes (t1 ': ts) c, c fmt) => MimeTypes (fmt ': t1 ': ts) c where
 134   mimeTypesMap =
 135     (mediaTypeFor (Proxy @fmt), MimeType @c @fmt Proxy)
 136       <| mimeTypesMap @(t1 ': ts) @c
 137
 138 matchAccept ::
 139   forall ts c.
 140   MimeTypes ts c =>
 141   BS.ByteString ->
 142   Maybe (MimeType c)
 143 matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
 144
 145 matchContent ::
 146   forall ts c.
 147   MimeTypes ts c =>
 148   BS.ByteString ->
 149   Maybe (MimeType c)
 150 matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
 151
 152 -- * Type 'MimeEncodable'
 153 class MediaTypeFor fmt => MimeEncodable a fmt where
 154   mimeEncode :: MimeEncoder a
 155 instance MimeEncodable () PlainText where
 156   mimeEncode () = mempty
 157
 158 -- | `BSB.stringUtf8`
 159 instance MimeEncodable String PlainText where
 160   mimeEncode = BSB.stringUtf8
 161
 162 instance MimeEncodable T.Text PlainText where
 163   mimeEncode = BSB.lazyByteString . BSL.fromStrict . T.encodeUtf8
 164 instance MimeEncodable TL.Text PlainText where
 165   mimeEncode = BSB.lazyByteString . TL.encodeUtf8
 166 instance MimeEncodable ST.ShortText PlainText where
 167   mimeEncode = ST.toBuilder
 168 instance MimeEncodable BS.ByteString OctetStream where
 169   mimeEncode = BSB.byteString
 170 instance MimeEncodable BSL.ByteString OctetStream where
 171   mimeEncode = BSB.lazyByteString
 172 instance MimeEncodable ST.ShortText OctetStream where
 173   mimeEncode = ST.toBuilder
 174 instance MimeEncodable Int PlainText where
 175   mimeEncode = BSB.intDec
 176
 177 -- | @Web.urlEncodeAsForm@
 178 -- Note that the @mimeDecode @_ @fmt (mimeEncode @_ @fmt x) == Right x@ law only
 179 -- holds if every element of x is non-null (i.e., not @("", "")@)
 180 -- instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
 181 --  mimeEncode _ = Web.urlEncodeAsForm
 182
 183 -- ** Type 'MimeEncoder'
 184
 185 type MimeEncoder a = a -> BSB.Builder
 186
 187 -- * Type 'MimeDecodable'
 188 class MediaTypeFor mt => MimeDecodable a mt where
 189   mimeDecode :: Proxy mt -> MimeDecoder a
 190
 191 -- mimeDecode p = mimeUnserializeWithType p (mimeType p)
 192
 193 -- ** Type 'MimeDecoder'
 194 type MimeDecoder a = BSL.ByteString -> Either String a
 195
 196 instance MimeDecodable () PlainText where
 197   mimeDecode _ bsl
 198     | BLC.null bsl = Right ()
 199     | otherwise = Left "not empty"
 200 instance MimeDecodable String PlainText where
 201   mimeDecode _ = Right . BLC.unpack
 202 instance MimeDecodable T.Text PlainText where
 203   mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
 204 instance MimeDecodable TL.Text PlainText where
 205   mimeDecode _ = left show . TL.decodeUtf8'
 206 instance MimeDecodable BS.ByteString OctetStream where
 207   mimeDecode _ = Right . BSL.toStrict
 208 instance MimeDecodable BSL.ByteString OctetStream where
 209   mimeDecode _ = Right
 210 instance MimeDecodable ST.ShortText PlainText where
 211   mimeDecode _ = maybe (Left "") Right . ST.fromByteString . BSL.toStrict
 212 instance MimeDecodable Int PlainText where
 213   mimeDecode _mt bsl =
 214     case readMaybe s of
 215       Just n -> Right n
 216       _ -> Left $ "cannot parse as Int: " <> s
 217     where
 218       s = TL.unpack (TL.decodeUtf8 bsl)
 219
 220 -- | @Web.urlDecodeAsForm@
 221 -- Note that the @mimeDecode @_ @fmt (mimeEncode @_ @fmt x) == Right x@ law only
 222 -- holds if every element of x is non-null (i.e., not @("", "")@)
 223 -- instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
 224 --  mimeDecode _ = left T.unpack . Web.urlDecodeAsForm