-- |
-- A minimal wrapper over xml-conduit parsing API bringing it to our standards.
module XmlParser.XmlConduitWrapper
  ( parseByteString,
    parseLazyByteString,
    parseFile,
  )
where

import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Text as Text
import qualified Text.XML as XmlConduit
import qualified Text.XML.Unresolved as XmlConduit (InvalidEventStream (..))
import XmlParser.Prelude

parseByteString :: ByteString -> Either Text XmlConduit.Document
parseByteString :: ByteString -> Either Text Document
parseByteString =
  ByteString -> Either Text Document
parseLazyByteString (ByteString -> Either Text Document)
-> (ByteString -> ByteString) -> ByteString -> Either Text Document
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
LazyByteString.fromStrict

parseLazyByteString :: LazyByteString.ByteString -> Either Text XmlConduit.Document
parseLazyByteString :: ByteString -> Either Text Document
parseLazyByteString ByteString
input =
  (SomeException -> Text)
-> Either SomeException Document -> Either Text Document
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> Text
renderError (ParseSettings -> ByteString -> Either SomeException Document
XmlConduit.parseLBS ParseSettings
settings ByteString
input)

parseFile :: FilePath -> IO (Either Text XmlConduit.Document)
parseFile :: FilePath -> IO (Either Text Document)
parseFile FilePath
path =
  (SomeException -> Text) -> IO Document -> IO (Either Text Document)
forall e e' a. Exception e => (e -> e') -> IO a -> IO (Either e' a)
tryMapping SomeException -> Text
renderError (ParseSettings -> FilePath -> IO Document
XmlConduit.readFile ParseSettings
settings FilePath
path)

settings :: XmlConduit.ParseSettings
settings :: ParseSettings
settings =
  ParseSettings
forall a. Default a => a
XmlConduit.def
    { psRetainNamespaces :: Bool
XmlConduit.psRetainNamespaces = Bool
True
    }

renderError :: SomeException -> Text
renderError :: SomeException -> Text
renderError SomeException
e
  | Just XMLException
e <- SomeException -> Maybe XMLException
forall e. Exception e => SomeException -> Maybe e
fromException @XmlConduit.XMLException SomeException
e =
    FilePath -> Text
forall a. IsString a => FilePath -> a
fromString (XMLException -> FilePath
forall a. Show a => a -> FilePath
show XMLException
e)
  | Just InvalidEventStream
e <- SomeException -> Maybe InvalidEventStream
forall e. Exception e => SomeException -> Maybe e
fromException @XmlConduit.InvalidEventStream SomeException
e =
    FilePath -> Text
forall a. IsString a => FilePath -> a
fromString (InvalidEventStream -> FilePath
forall a. Show a => a -> FilePath
show InvalidEventStream
e)
  | Just (XmlConduit.UnresolvedEntityException Set Text
e) <- SomeException -> Maybe UnresolvedEntityException
forall e. Exception e => SomeException -> Maybe e
fromException @XmlConduit.UnresolvedEntityException SomeException
e =
    Text
"Unresolved entities: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," (Set Text -> [Item (Set Text)]
forall l. IsList l => l -> [Item l]
toList Set Text
e)
  | Bool
otherwise =
    -- FIXME: Find other cases and do something more user-friendly about them
    FilePath -> Text
forall a. IsString a => FilePath -> a
fromString (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)