src/Webc/MIME.hs

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