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