diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c)2011, Michael Snoyman - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Michael Snoyman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c)2011, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,7 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Text/XML/Catalog.hs b/Text/XML/Catalog.hs --- a/Text/XML/Catalog.hs +++ b/Text/XML/Catalog.hs @@ -1,92 +1,88 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | Used for loading a catalog file, caching DTDs and applying DTDs to --- documents. -module Text.XML.Catalog - ( -- * Catalogs - Catalog - , PubSys (..) - , loadCatalog - -- * Resolving - , resolveURI - ) where - -import Prelude hiding (FilePath) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Text.XML as X -import Control.Monad (foldM) -import Network.URI.Enumerator -import qualified Data.Text as T -import Control.Monad.IO.Class (MonadIO) - --- | Either a public or system identifier. -data PubSys = Public Text | System Text - deriving (Eq, Show, Ord) - --- | An XML catalog, mapping public and system identifiers to filepaths. -type Catalog = Map.Map PubSys URI - --- | Load a 'Catalog' from the given path. -loadCatalog :: MonadIO m => SchemeMap m -> URI -> m Catalog -loadCatalog sm uri = do - X.Document _ (X.Element _ _ ns) _ <- X.parseEnum_ X.def $ readURI sm uri - foldM addNode Map.empty ns - where - addNode c (X.NodeElement (X.Element name as ns)) = do - 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 (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 (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 - -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 parseURI system of - Just uri -> Just uri - Nothing -> do - base <- mbase - ref <- parseURIReference system - ref `relativeTo` base - Just x -> Just x +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | Used for loading a catalog file, caching DTDs and applying DTDs to +-- documents. +module Text.XML.Catalog + ( -- * Catalogs + Catalog + , PubSys (..) + , loadCatalog + -- * Resolving + , resolveURI + ) where + +import Prelude hiding (FilePath) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Text.XML as X +import Control.Monad (foldM) +import Network.URI.Enumerator +import qualified Data.Text as T +import Control.Monad.IO.Class (MonadIO) + +-- | Either a public or system identifier. +data PubSys = Public Text | System Text + deriving (Eq, Show, Ord) + +-- | An XML catalog, mapping public and system identifiers to filepaths. +type Catalog = Map.Map PubSys URI + +-- | Load a 'Catalog' from the given path. +loadCatalog :: MonadIO m => SchemeMap m -> URI -> m Catalog +loadCatalog sm uri = do + X.Document _ (X.Element _ _ ns) _ <- X.parseEnum_ X.def $ readURI sm uri + foldM (addNode Nothing) Map.empty ns + where + addNode mbase0 c (X.NodeElement (X.Element name as ns)) = do + c'' <- c' + foldM (addNode mbase) c'' ns + where + mbase = maybe mbase0 Just $ lookup "{http://www.w3.org/XML/1998/namespace}base" as + withBase = maybe id T.append mbase + + 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 (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 (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 + +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 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,22 +1,22 @@ -Name: xml-catalog -Version: 0.2.0 -Synopsis: Parse XML catalog files -Homepage: http://github.com/snoyberg/xml -License: BSD3 -License-file: LICENSE -Author: Michael Snoyman -Maintainer: michaels@suite-sol.com -Category: Text -Build-type: Simple -Cabal-version: >=1.6 -Description: Parse XML catalog files - -Library - Exposed-modules: Text.XML.Catalog - Build-depends: base >= 4 && < 5 - , text >= 0.11 && < 1.0 - , containers >= 0.2 && < 0.5 - , xml-enumerator >= 0.4 && < 0.5 - , uri-enumerator >= 0.0 && < 0.1 - , transformers >= 0.2 && < 0.3 - Ghc-options: -Wall +Name: xml-catalog +Version: 0.3.0.1 +Synopsis: Parse XML catalog files +Homepage: http://github.com/snoyberg/xml +License: BSD3 +License-file: LICENSE +Author: Michael Snoyman +Maintainer: michaels@suite-sol.com +Category: Text +Build-type: Simple +Cabal-version: >=1.6 +Description: Parse XML catalog files + +Library + Exposed-modules: Text.XML.Catalog + Build-depends: base >= 4 && < 5 + , text >= 0.11 && < 1.0 + , containers >= 0.2 && < 0.5 + , xml-enumerator >= 0.4 && < 0.5 + , uri-enumerator >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.3 + Ghc-options: -Wall