xml-catalog 0.0.0 → 0.2.0
raw patch · 2 files changed
+49/−110 lines, 2 filesdep −bytestringdep −dtd-textdep −dtd-types
Dependencies removed: bytestring, dtd-text, dtd-types, enumerator
Files
- Text/XML/Catalog.hs +48/−105
- xml-catalog.cabal +1/−5
Text/XML/Catalog.hs view
@@ -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
xml-catalog.cabal view
@@ -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