Symantic/HTTP/Mime.hs

   1 module Symantic.HTTP.Mime
   2  ( module Symantic.HTTP.Mime
   3  , module Symantic.HTTP.Mime.Type
   4  ) where
   5
   6 import Control.Arrow (left)
   7 import Data.Either (Either(..))
   8 import Data.Function (($), (.), id)
   9 import Data.Proxy (Proxy(..))
  10 import Data.String (String)
  11 import Text.Show (Show(..))
  12 import qualified Data.ByteString as BS
  13 import qualified Data.ByteString.Lazy as BSL
  14 import qualified Data.ByteString.Lazy.Char8 as BLC
  15 import qualified Data.Text as T
  16 import qualified Data.Text.Encoding as T
  17 import qualified Data.Text.Lazy as TL
  18 import qualified Data.Text.Lazy.Encoding as TL
  19 import qualified Web.FormUrlEncoded as Web
  20
  21 import Symantic.HTTP.Mime.Type
  22
  23 {-
  24 -- * Type 'MimeType'
  25 data MimeType mt a where
  26  MimeType ::
  27   forall mt.
  28   MimeEncodable mt a =>
  29   MimeDecodable mt a =>
  30   MimeType mt a
  31
  32 mimeType :: MediaType -> MimeType mt
  33 -}
  34
  35 {-
  36 newtype AcceptHeader = AcceptHeader BS.ByteString
  37         deriving (Eq, Show, Read, Typeable, Generic)
  38 -}
  39
  40 -- * Type 'MimeEncodable'
  41 class MediaTypeable mt => MimeEncodable a mt where
  42         mimeEncode :: Proxy mt -> Serializer a
  43 instance MimeEncodable () PlainText where
  44         mimeEncode _ () = BLC.pack ""
  45 -- | @BSL.fromStrict . T.encodeUtf8@
  46 instance MimeEncodable String PlainText where
  47         mimeEncode _ = BLC.pack
  48 instance MimeEncodable T.Text PlainText where
  49         mimeEncode _ = BSL.fromStrict . T.encodeUtf8
  50 instance MimeEncodable TL.Text PlainText where
  51         mimeEncode _ = TL.encodeUtf8
  52 instance MimeEncodable BS.ByteString OctetStream where
  53         mimeEncode _ = BSL.fromStrict
  54 instance MimeEncodable BSL.ByteString OctetStream where
  55         mimeEncode _ = id
  56 -- | @Web.urlEncodeAsForm@
  57 -- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
  58 -- holds if every element of x is non-null (i.e., not @("", "")@)
  59 instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
  60         mimeEncode _ = Web.urlEncodeAsForm
  61 {-
  62 -- | `encode`
  63 instance {-# OVERLAPPABLE #-}
  64          ToJSON a => MimeEncodable JSON a where
  65         mimeEncode _ = encode
  66 -}
  67
  68 -- ** Type 'Serializer'
  69 type Serializer a = a -> BSL.ByteString
  70
  71 {-
  72 class (AllMime list) => AllCTSerialize (list :: [*]) a where
  73         -- If the Accept header can be matched, returns (Just) a tuple of the
  74         -- Content-Type and response (serialization of @a@ into the appropriate
  75         -- mimetype).
  76         handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
  77
  78 instance {-# OVERLAPPABLE #-}
  79          (Accept ct, AllMime cts, AllMimeSerialize (ct ': cts) a) => AllCTSerialize (ct ': cts) a where
  80         handleAcceptH _ (AcceptHeader accept) val = Media.mapAcceptMedia lkup accept
  81         where
  82         pctyps = Proxy :: Proxy (ct ': cts)
  83         amrs   = allMimeSerialize pctyps val
  84         lkup   = fmap (\(a,b) -> (a, (BSL.fromStrict $ Media.renderHeader a, b))) amrs
  85
  86 instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTSerialize '[] () where
  87   handleAcceptH _ _ _ = error "unreachable"
  88 -}
  89
  90 -- * Type 'MimeDecodable'
  91 class MediaTypeable mt => MimeDecodable a mt where
  92         mimeDecode :: Proxy mt -> Unserializer a
  93         -- mimeDecode p = mimeUnserializeWithType p (mimeType p)
  94
  95 -- ** Type 'Unserializer'
  96 type Unserializer a = BSL.ByteString -> Either String a
  97
  98         {-
  99         -- | Variant which is given the actual 'Media.MediaType' provided by the other party.
 100         --
 101         -- In the most cases you don't want to branch based on the 'Media.MediaType'.
 102         -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
 103         mimeUnserializeWithType :: Proxy mt -> Media.MediaType -> Unserializer a
 104         mimeUnserializeWithType p _ = mimeDecode p
 105         {-# MINIMAL mimeDecode | mimeUnserializeWithType #-}
 106         -}
 107 instance MimeDecodable () PlainText where
 108         mimeDecode _ t =
 109                 if BLC.null t
 110                 then Right ()
 111                 else Left "not empty"
 112 instance MimeDecodable String PlainText where
 113         mimeDecode _ = Right . BLC.unpack
 114 instance MimeDecodable T.Text PlainText where
 115         mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
 116 instance MimeDecodable TL.Text PlainText where
 117         mimeDecode _ = left show . TL.decodeUtf8'
 118 instance MimeDecodable BS.ByteString OctetStream where
 119         mimeDecode _ = Right . BSL.toStrict
 120 instance MimeDecodable BSL.ByteString OctetStream where
 121         mimeDecode _ = Right
 122 -- | @Web.urlDecodeAsForm@
 123 -- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
 124 -- holds if every element of x is non-null (i.e., not @("", "")@)
 125 instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
 126         mimeDecode _ = left T.unpack . Web.urlDecodeAsForm
 127 {-
 128 -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
 129 -- objects and arrays.
 130 --
 131 -- Will handle trailing whitespace, but not trailing junk. ie.
 132 --
 133 -- >>> eitherDecodeLenient "1 " :: Either String Int
 134 -- Right 1
 135 --
 136 -- >>> eitherDecodeLenient "1 junk" :: Either String Int
 137 -- Left "trailing junk after valid JSON: endOfInput"
 138 eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
 139 eitherDecodeLenient input =
 140     parseOnly parser (cs input) >>= parseEither parseJSON
 141   where
 142     parser = skipSpace
 143           *> Data.Aeson.Parser.value
 144           <* skipSpace
 145           <* (endOfInput <?> "trailing junk after valid JSON")
 146
 147 -- | `eitherDecode`
 148 instance FromJSON a => MimeDecodable JSON a where
 149         mimeDecode _ = eitherDecodeLenient
 150 -}
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164 {-
 165 -- | A type for responses without content-body.
 166 data NoContent = NoContent
 167   deriving (Show, Eq)
 168
 169
 170
 171 class AllCTUnserialize (list :: [*]) a where
 172     canHandleCTypeH
 173         :: Proxy list
 174         -> ByteString  -- Content-Type header
 175         -> Maybe (ByteString -> Either String a)
 176
 177     handleCTypeH :: Proxy list
 178                  -> ByteString     -- Content-Type header
 179                  -> ByteString     -- Request body
 180                  -> Maybe (Either String a)
 181     handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
 182
 183 instance ( AllMimeUnserialize ctyps a ) => AllCTUnserialize ctyps a where
 184     canHandleCTypeH p ctypeH =
 185         Media.mapContentMedia (allMimeUnserialize p) (cs ctypeH)
 186
 187 --------------------------------------------------------------------------
 188 -- * Utils (Internal)
 189
 190 class AllMime (list :: [*]) where
 191     allMime :: Proxy list -> [Media.MediaType]
 192
 193 instance AllMime '[] where
 194     allMime _ = []
 195
 196 instance (MediaType ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
 197     allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
 198       where
 199         pctyp  = Proxy :: Proxy ctyp
 200         pctyps = Proxy :: Proxy ctyps
 201
 202 canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
 203 canHandleAcceptH p (AcceptHeader h ) = isJust $ Media.matchAccept (allMime p) h
 204
 205 --------------------------------------------------------------------------
 206 -- Check that all elements of list are instances of MimeEncodable
 207 --------------------------------------------------------------------------
 208 class (AllMime list) => AllMimeSerialize (list :: [*]) a where
 209     allMimeSerialize :: Proxy list
 210                   -> a                              -- value to serialize
 211                   -> [(Media.MediaType, ByteString)]    -- content-types/response pairs
 212
 213 instance {-# OVERLAPPABLE #-} ( MimeEncodable ctyp a ) => AllMimeSerialize '[ctyp] a where
 214     allMimeSerialize _ a = map (, bs) $ NE.toList $ contentTypes pctyp
 215       where
 216         bs    = mimeEncode pctyp a
 217         pctyp = Proxy :: Proxy ctyp
 218
 219 instance {-# OVERLAPPABLE #-}
 220          ( MimeEncodable ctyp a
 221          , AllMimeSerialize (ctyp' ': ctyps) a
 222          ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) a where
 223     allMimeSerialize _ a =
 224         map (, bs) (NE.toList $ contentTypes pctyp)
 225         ++ allMimeSerialize pctyps a
 226       where
 227         bs     = mimeEncode pctyp a
 228         pctyp  = Proxy :: Proxy ctyp
 229         pctyps = Proxy :: Proxy (ctyp' ': ctyps)
 230
 231
 232 -- Ideally we would like to declare a 'MimeEncodable a NoContent' instance, and
 233 -- then this would be taken care of. However there is no more specific instance
 234 -- between that and 'MimeEncodable JSON a', so we do this instead
 235 instance {-# OVERLAPPING #-} ( MediaType ctyp ) => AllMimeSerialize '[ctyp] NoContent where
 236     allMimeSerialize _ _ = map (, "") $ NE.toList $ contentTypes pctyp
 237       where
 238         pctyp = Proxy :: Proxy ctyp
 239
 240 instance {-# OVERLAPPING #-}
 241          ( AllMime (ctyp ': ctyp' ': ctyps)
 242          ) => AllMimeSerialize (ctyp ': ctyp' ': ctyps) NoContent where
 243     allMimeSerialize p _ = zip (allMime p) (repeat "")
 244
 245 --------------------------------------------------------------------------
 246 -- Check that all elements of list are instances of MimeDecodable
 247 --------------------------------------------------------------------------
 248 class (AllMime list) => AllMimeUnserialize (list :: [*]) a where
 249     allMimeUnserialize :: Proxy list
 250                     -> [(Media.MediaType, ByteString -> Either String a)]
 251 instance AllMimeUnserialize '[] a where
 252     allMimeUnserialize _ = []
 253 instance ( MimeDecodable ctyp a
 254          , AllMimeUnserialize ctyps a
 255          ) => AllMimeUnserialize (ctyp ': ctyps) a where
 256     allMimeUnserialize _ =
 257         map mk (NE.toList $ contentTypes pctyp)
 258         ++ allMimeUnserialize pctyps
 259       where
 260         mk ct   = (ct, mimeUnserializeWithType pctyp ct)
 261         pctyp  = Proxy :: Proxy ctyp
 262         pctyps = Proxy :: Proxy ctyps
 263 -}
 264
 265
 266