Symantic/HTTP/Mime.hs

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