Language/Symantic/HTTP/Mime.hs

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