diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/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 new file mode 100644 --- /dev/null +++ b/Text/XML/Catalog.hs @@ -0,0 +1,149 @@ +{-# 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 + -- * DTD caching + , DTDCache + , dcSchemeMap + , newDTDCache + , loadDTD + , UnknownExternalID (..) + -- * Applying DTDs + , applyDTD + ) 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 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)) + +-- | 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 + foldM addNode c' ns + where + 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 + "{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 + 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 + 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 diff --git a/xml-catalog.cabal b/xml-catalog.cabal new file mode 100644 --- /dev/null +++ b/xml-catalog.cabal @@ -0,0 +1,26 @@ +Name: xml-catalog +Version: 0.0.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 + , 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