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