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