{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-- | 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.Conduit
import qualified Data.Text as T
import Data.Conduit hiding (Source, Sink, Conduit)
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 -> URI -> m Catalog
loadCatalog sm uri = do
    X.Document _ (X.Element _ _ ns) _ <- liftIO $ runResourceT $
        readURI sm uri $$ X.sinkDoc X.def
    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 $ Map.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 (Map.lookup "publicId" as, Map.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 (Map.lookup "systemId" as, Map.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 Map.lookup "catalog" as of
                        Just catalog ->
                            case parseURIReference (withBase 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