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