diff --git a/Text/XML/Catalog.hs b/Text/XML/Catalog.hs --- a/Text/XML/Catalog.hs +++ b/Text/XML/Catalog.hs @@ -7,14 +7,8 @@ Catalog , PubSys (..) , loadCatalog - -- * DTD caching - , DTDCache - , dcSchemeMap - , newDTDCache - , loadDTD - , UnknownExternalID (..) - -- * Applying DTDs - , applyDTD + -- * Resolving + , resolveURI ) where import Prelude hiding (FilePath) @@ -22,19 +16,9 @@ import Data.Text (Text) import qualified Text.XML as X import Control.Monad (foldM) -import qualified Data.IORef as I -import Data.XML.DTD.Parse (parseDTD) -import qualified Data.XML.DTD.Types as D -import Control.Exception (Exception, throwIO) -import Data.Typeable (Typeable) -import Data.Maybe (mapMaybe) import Network.URI.Enumerator -import Data.Enumerator (run_, ($$)) -import Data.Enumerator.List (consume) -import Data.Text.Lazy.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.ByteString.Lazy as L -import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text as T +import Control.Monad.IO.Class (MonadIO) -- | Either a public or system identifier. data PubSys = Public Text | System Text @@ -50,100 +34,59 @@ foldM addNode Map.empty ns where addNode c (X.NodeElement (X.Element name as ns)) = do - foldM addNode c' ns + c'' <- c' + foldM addNode c'' ns where + -- FIXME handle hierarchies + base = + case lookup "{http://www.w3.org/XML/1998/namespace}base" as of + Nothing -> "" + Just x -> x + withBase = T.append base + c' = case name of "{urn:oasis:names:tc:entity:xmlns:xml:catalog}public" -> case (lookup "publicId" as, lookup "uri" as) of (Just pid, Just ref) -> - case parseURIReference ref >>= flip relativeTo uri of - Just uri' -> Map.insert (Public pid) uri' c - Nothing -> c - _ -> c + case parseURIReference (withBase ref) >>= flip relativeTo uri of + Just uri' -> return $ Map.insert (Public pid) uri' c + Nothing -> return c + _ -> return c "{urn:oasis:names:tc:entity:xmlns:xml:catalog}system" -> case (lookup "systemId" as, lookup "uri" as) of (Just sid, Just ref) -> - case parseURIReference ref >>= flip relativeTo uri of - Just uri' -> Map.insert (System sid) uri' c - Nothing -> c - _ -> c - _ -> c + case parseURIReference (withBase ref) >>= flip relativeTo uri of + Just uri' -> return $ Map.insert (System sid) uri' c + Nothing -> return c + _ -> return c + "{urn:oasis:names:tc:entity:xmlns:xml:catalog}nextCatalog" -> + case lookup "catalog" as of + Just catalog -> + case parseURIReference catalog >>= flip relativeTo uri of + Just uri' -> do + c'' <- loadCatalog sm uri' + return $ c'' `Map.union` c + Nothing -> return c + Nothing -> return c + _ -> return c addNode c _ = return c -data DTDCache m = DTDCache - { _dcCache :: I.IORef (Map.Map PubSys D.DTD) - , _dcCatalog :: Catalog - , dcSchemeMap :: SchemeMap m - } - -newDTDCache :: MonadIO m => Catalog -> SchemeMap m -> m (DTDCache m) -newDTDCache c sm = do - x <- liftIO $ I.newIORef Map.empty - return $ DTDCache x c sm - -loadDTD :: MonadIO m => DTDCache m -> X.ExternalID -> m D.DTD -loadDTD (DTDCache icache catalog sm) ext = do - res <- liftIO $ fmap (Map.lookup pubsys) $ I.readIORef icache - case res of - Just dtd -> return dtd +resolveURI :: Catalog + -> Maybe URI -- ^ base URI for relative system identifiers + -> X.ExternalID + -> Maybe URI +resolveURI catalog mbase (X.PublicID public system) = + case Map.lookup (Public public) catalog of + Nothing -> resolveURI catalog mbase (X.SystemID system) + Just x -> Just x +resolveURI catalog mbase (X.SystemID system) = + case Map.lookup (System system) catalog of Nothing -> - case Map.lookup pubsys catalog of - Nothing -> liftIO $ throwIO $ UnknownExternalID ext - Just fp -> do - bss <- run_ $ readURI sm fp $$ consume - let dtd = parseDTD $ decodeUtf8With lenientDecode $ L.fromChunks bss - liftIO $ I.atomicModifyIORef icache $ \m -> - (Map.insert pubsys dtd m, ()) - return dtd - where - pubsys = - case ext of - X.SystemID t -> System t - X.PublicID t _ -> Public t - -data UnknownExternalID = UnknownExternalID X.ExternalID - deriving (Show, Typeable) -instance Exception UnknownExternalID - -applyDTD :: MonadIO m => DTDCache m -> X.Document -> m X.Document -applyDTD dc doc@(X.Document pro@(X.Prologue _ mdoctype _) root epi) = - case mdoctype of - Just (X.Doctype _ (Just extid)) -> do - dtd <- loadDTD dc extid - let attrs = toAttrs dtd - let root' = go attrs root - return $ X.Document pro root' epi - _ -> return doc - where - go attrs (X.Element name as ns) = - X.Element name as' ns' - where - as' = - case Map.lookup name attrs of - Nothing -> as - Just x -> foldr goa as x - ns' = map gon ns - gon (X.NodeElement e) = X.NodeElement $ go attrs e - gon n = n - goa (name, Fixed t) as = (name, t) : filter (\(n, _) -> name /= n) as - goa (name, Def t) as = - case lookup name as of - Nothing -> (name, t) : as - Just _ -> as - -data Att = Def Text | Fixed Text - -toAttrs :: D.DTD -> Map.Map X.Name [(X.Name, Att)] -toAttrs (D.DTD _ comps) = - Map.fromList $ mapMaybe go comps - where - go (D.DTDAttList (D.AttList lname atts)) = Just $ (X.Name lname Nothing Nothing, mapMaybe go' atts) - go _ = Nothing - go' (D.AttDecl lname _ def) = - case def of - D.AttFixed t -> Just (name, Fixed t) - D.AttDefaultValue t -> Just (name, Def t) - _ -> Nothing - where - name = X.Name lname Nothing Nothing + case parseURI system of + Just uri -> Just uri + Nothing -> do + base <- mbase + ref <- parseURIReference system + ref `relativeTo` base + Just x -> Just x diff --git a/xml-catalog.cabal b/xml-catalog.cabal --- a/xml-catalog.cabal +++ b/xml-catalog.cabal @@ -1,5 +1,5 @@ Name: xml-catalog -Version: 0.0.0 +Version: 0.2.0 Synopsis: Parse XML catalog files Homepage: http://github.com/snoyberg/xml License: BSD3 @@ -15,12 +15,8 @@ Exposed-modules: Text.XML.Catalog Build-depends: base >= 4 && < 5 , text >= 0.11 && < 1.0 - , dtd-types >= 0.3 && < 0.4 - , dtd-text >= 0.1.1.1 && < 0.2 , containers >= 0.2 && < 0.5 , xml-enumerator >= 0.4 && < 0.5 - , bytestring >= 0.9 && < 0.10 - , enumerator >= 0.4.14 && < 0.5 , uri-enumerator >= 0.0 && < 0.1 , transformers >= 0.2 && < 0.3 Ghc-options: -Wall