servant-xml-conduit-0.1.0.4: src/Servant/XML/Conduit.hs

{-|
Module      : Servant.XML.Conduit
Description : Servant bindings for XML using xml-conduit
Copyright   : (c) CNRS, 2023-present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}

module Servant.XML.Conduit where

import Data.Bifunctor (first)
import Data.ByteString.Lazy qualified as BSL
import Network.HTTP.Media qualified as M
import Servant.API
import Text.XML qualified as XML


data XML

instance Accept XML where
  contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")

instance MimeRender XML XML.Document where
  mimeRender _ doc = XML.renderLBS XML.def doc

{-| Function to decode a lazy `ByteString' into 'XML.Document'. The
  reason we don't privde a @'MimeUnrender' 'XML' 'XML.Document'@ instance is
  that we don't want to force users with a predefined 'FromXML'
  typeclass.

  If we added

  @
    instance 'MimeUnrender' 'XML' 'XML.Document' where
      mimeUnrender _ bs = first show $ 'XML.parseLBS' 'XML.def' bs
  @

  we immediately arrive at overlapping instances problem when we try to define

  @
    instance FromXML a => 'MimeUnrender' 'XML' a ...
  @

  So, just define this in your code:

  @
    data ParseError =
      ErrorNoElementFound Text
      | ...

    class FromXML a where
      fromXML :: (Functor m, Applicative m, MonadError ParseError m) => 'Text.XML.Cursor.Cursor' -> m a

    instance (FromXML a) => 'MimeUnrender' 'XML' a where
      mimeUnrender _ctype bs = case 'mimeUnrenderXML' bs of
        Left err -> Left err
        Right doc -> first show $ fromXML ('Text.XML.Cursor.fromDocument' doc)
  @
-}
mimeUnrenderXML :: BSL.ByteString -> Either String XML.Document
mimeUnrenderXML bs = first show $ XML.parseLBS XML.def bs