URIHandling.hs

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.XmlState.URIHandling
   Copyright  : Copyright (C) 2010 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   the basic state arrows for URI handling

-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.XmlState.URIHandling
where

import Control.Arrow                            -- arrow classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf

import Control.Arrow.ArrowIO

import Control.Monad                    ( mzero
                                        , mplus )

import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.Arrow.XmlState.TraceHandling

import Data.Maybe

import Network.URI                      ( URI
                                        , escapeURIChar
                                        , isUnescapedInURI
                                        , nonStrictRelativeTo
                                        , parseURIReference
                                        , uriAuthority
                                        , uriFragment
                                        , uriPath
                                        , uriPort
                                        , uriQuery
                                        , uriRegName
                                        , uriScheme
                                        , uriUserInfo
                                        )

import System.Directory                 ( getCurrentDirectory )

-- ------------------------------------------------------------

-- | set the base URI of a document, used e.g. for reading includes, e.g. external entities,
-- the input must be an absolute URI

setBaseURI              :: IOStateArrow s String String
setBaseURI              = setSysVar theBaseURI
                          >>>
                          traceValue 2 (("setBaseURI: new base URI is " ++) . show)

-- | read the base URI from the globale state

getBaseURI              :: IOStateArrow s b String
getBaseURI              = getSysVar theBaseURI
                          >>>
                          ( ( getDefaultBaseURI
                              >>>
                              setBaseURI
                              >>>
                              getBaseURI
                            )
                            `when`
                            isA null                                -- set and get it, if not yet done
                          )

-- | change the base URI with a possibly relative URI, can be used for
-- evaluating the xml:base attribute. Returns the new absolute base URI.
-- Fails, if input is not parsable with parseURIReference
--
-- see also: 'setBaseURI', 'mkAbsURI'

changeBaseURI           :: IOStateArrow s String String
changeBaseURI           = mkAbsURI >>> setBaseURI

-- | set the default base URI, if parameter is null, the system base (@ file:\/\/\/\<cwd\>\/ @) is used,
-- else the parameter, must be called before any document is read

setDefaultBaseURI       :: String -> IOStateArrow s b String
setDefaultBaseURI base  = ( if null base
                            then arrIO getDir
                            else constA base
                          )
                          >>>
                          setSysVar theDefaultBaseURI
                          >>>
                          traceValue 2 (("setDefaultBaseURI: new default base URI is " ++) . show)
    where
    getDir _            = do
                          cwd <- getCurrentDirectory
                          return ("file://" ++ normalize cwd ++ "/")

    -- under Windows getCurrentDirectory returns something like: "c:\path\to\file"
    -- backslaches are not allowed in URIs and paths must start with a /
    -- so this is transformed into "/c:/path/to/file"

    normalize wd'@(d : ':' : _)
        | d `elem` ['A'..'Z']
          ||
          d `elem` ['a'..'z']
                        = '/' : concatMap win32ToUriChar wd'
    normalize wd'       = concatMap escapeNonUriChar wd'

    win32ToUriChar '\\' = "/"
    win32ToUriChar c    = escapeNonUriChar c

    escapeNonUriChar c  = escapeURIChar isUnescapedInURI c   -- from Network.URI


-- | get the default base URI

getDefaultBaseURI       :: IOStateArrow s b String
getDefaultBaseURI       = getSysVar theDefaultBaseURI            -- read default uri in system  state
                          >>>
                          ( ( setDefaultBaseURI ""                  -- set the default uri in system state
                              >>>
                              getDefaultBaseURI
                            )
                            `when` isA null
                          )                                         -- when uri not yet set

-- ------------------------------------------------------------

-- | remember base uri, run an arrow and restore the base URI, used with external entity substitution

runInLocalURIContext    :: IOStateArrow s b c -> IOStateArrow s b c
runInLocalURIContext f  = localSysVar theBaseURI f

-- ----------------------------------------------------------

-- | parse a URI reference, in case of a failure,
-- try to escape unescaped chars, convert backslashes to slashes for windows paths,
-- and try parsing again

parseURIReference'      :: String -> Maybe URI
parseURIReference' uri
    = parseURIReference uri
      `mplus`
      ( if unesc
        then parseURIReference uri'
        else mzero
      )
    where
    unesc       = not . all isUnescapedInURI $ uri

    escape '\\' = "/"
    escape c    = escapeURIChar isUnescapedInURI c

    uri'        = concatMap escape uri

-- | compute the absolut URI for a given URI and a base URI

expandURIString :: String -> String -> Maybe String
expandURIString uri base
    = do
      base' <- parseURIReference' base
      uri'  <- parseURIReference' uri
      abs'  <- nonStrictRelativeTo uri' base'
      return $ show abs'

-- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing

expandURI               :: ArrowXml a => a (String, String) String
expandURI
    = arrL (maybeToList . uncurry expandURIString)

-- | arrow for expanding an input URI into an absolute URI using global base URI, fails if input is not a legal URI

mkAbsURI                :: IOStateArrow s String String
mkAbsURI
    = ( this &&& getBaseURI ) >>> expandURI

-- | arrow for selecting the scheme (protocol) of the URI, fails if input is not a legal URI.
--
-- See Network.URI for URI components

getSchemeFromURI        :: ArrowList a => a String String
getSchemeFromURI        = getPartFromURI scheme
    where
    scheme = init . uriScheme

-- | arrow for selecting the registered name (host) of the URI, fails if input is not a legal URI

getRegNameFromURI       :: ArrowList a => a String String
getRegNameFromURI       = getPartFromURI host
    where
    host = maybe "" uriRegName . uriAuthority

-- | arrow for selecting the port number of the URI without leading \':\', fails if input is not a legal URI

getPortFromURI          :: ArrowList a => a String String
getPortFromURI          = getPartFromURI port
    where
    port = dropWhile (==':') . maybe "" uriPort . uriAuthority

-- | arrow for selecting the user info of the URI without trailing \'\@\', fails if input is not a legal URI

getUserInfoFromURI              :: ArrowList a => a String String
getUserInfoFromURI              = getPartFromURI ui
    where
    ui = reverse . dropWhile (=='@') . reverse . maybe "" uriUserInfo . uriAuthority

-- | arrow for computing the path component of an URI, fails if input is not a legal URI

getPathFromURI          :: ArrowList a => a String String
getPathFromURI          = getPartFromURI uriPath

-- | arrow for computing the query component of an URI, fails if input is not a legal URI

getQueryFromURI         :: ArrowList a => a String String
getQueryFromURI         = getPartFromURI uriQuery

-- | arrow for computing the fragment component of an URI, fails if input is not a legal URI

getFragmentFromURI      :: ArrowList a => a String String
getFragmentFromURI      = getPartFromURI uriFragment

-- | arrow for computing the path component of an URI, fails if input is not a legal URI

getPartFromURI          :: ArrowList a => (URI -> String) -> a String String
getPartFromURI sel
    = arrL (maybeToList . getPart)
      where
      getPart s = do
                  uri <- parseURIReference' s
                  return (sel uri)

-- ------------------------------------------------------------