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

{- |
   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 :: forall s. IOStateArrow s String String
setBaseURI              = forall c s. Selector XIOSysState c -> IOStateArrow s c c
setSysVar Selector XIOSysState String
theBaseURI
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
2 ((String
"setBaseURI: new base URI is " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

-- | read the base URI from the globale state

getBaseURI              :: IOStateArrow s b String
getBaseURI :: forall s b. IOStateArrow s b String
getBaseURI              = forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theBaseURI
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( ( forall s b. IOStateArrow s b String
getDefaultBaseURI
                              forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              forall s. IOStateArrow s String String
setBaseURI
                              forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              forall s b. IOStateArrow s b String
getBaseURI
                            )
                            forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                            forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA forall (t :: * -> *) a. Foldable t => t a -> Bool
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 :: forall s. IOStateArrow s String String
changeBaseURI           = forall s. IOStateArrow s String String
mkAbsURI forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall s. IOStateArrow s String String
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 :: forall s b. String -> IOStateArrow s b String
setDefaultBaseURI String
base  = ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base
                            then forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO forall {p}. p -> IO String
getDir
                            else forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
base
                          )
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall c s. Selector XIOSysState c -> IOStateArrow s c c
setSysVar Selector XIOSysState String
theDefaultBaseURI
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
2 ((String
"setDefaultBaseURI: new default base URI is " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)
    where
    getDir :: p -> IO String
getDir p
_            = do
                          String
cwd <- IO String
getCurrentDirectory
                          forall (m :: * -> *) a. Monad m => a -> m a
return (String
"file://" forall a. [a] -> [a] -> [a]
++ String -> String
normalize String
cwd forall a. [a] -> [a] -> [a]
++ String
"/")

    -- 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 :: String -> String
normalize wd' :: String
wd'@(Char
d : Char
':' : String
_)
        | Char
d forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']
          Bool -> Bool -> Bool
||
          Char
d forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z']
                        = Char
'/' forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
win32ToUriChar String
wd'
    normalize String
wd'       = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeNonUriChar String
wd'

    win32ToUriChar :: Char -> String
win32ToUriChar Char
'\\' = String
"/"
    win32ToUriChar Char
c    = Char -> String
escapeNonUriChar Char
c

    escapeNonUriChar :: Char -> String
escapeNonUriChar Char
c  = (Char -> Bool) -> Char -> String
escapeURIChar Char -> Bool
isUnescapedInURI Char
c   -- from Network.URI


-- | get the default base URI

getDefaultBaseURI       :: IOStateArrow s b String
getDefaultBaseURI :: forall s b. IOStateArrow s b String
getDefaultBaseURI       = forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theDefaultBaseURI            -- read default uri in system  state
                          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( ( forall s b. String -> IOStateArrow s b String
setDefaultBaseURI String
""                  -- set the default uri in system state
                              forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              forall s b. IOStateArrow s b String
getDefaultBaseURI
                            )
                            forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA forall (t :: * -> *) a. Foldable t => t a -> Bool
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 :: forall s b c. IOStateArrow s b c -> IOStateArrow s b c
runInLocalURIContext IOStateArrow s b c
f  = forall c s a b.
Selector XIOSysState c -> IOStateArrow s a b -> IOStateArrow s a b
localSysVar Selector XIOSysState String
theBaseURI IOStateArrow s b c
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' :: String -> Maybe URI
parseURIReference' String
uri
    = String -> Maybe URI
parseURIReference String
uri
      forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
      ( if Bool
unesc
        then String -> Maybe URI
parseURIReference String
uri'
        else forall (m :: * -> *) a. MonadPlus m => m a
mzero
      )
    where
    unesc :: Bool
unesc       = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUnescapedInURI forall a b. (a -> b) -> a -> b
$ String
uri

    escape :: Char -> String
escape Char
'\\' = String
"/"
    escape Char
c    = (Char -> Bool) -> Char -> String
escapeURIChar Char -> Bool
isUnescapedInURI Char
c

    uri' :: String
uri'        = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escape String
uri

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

expandURIString :: String -> String -> Maybe String
expandURIString :: String -> String -> Maybe String
expandURIString String
uri String
base
    = do
      URI
base' <- String -> Maybe URI
parseURIReference' String
base
      URI
uri'  <- String -> Maybe URI
parseURIReference' String
uri
      --  abs' <- nonStrictRelativeTo uri' base'
      let abs' :: URI
abs' =  URI -> URI -> URI
nonStrictRelativeTo URI
uri' URI
base'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show URI
abs'

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

expandURI               :: ArrowXml a => a (String, String) String
expandURI :: forall (a :: * -> * -> *). ArrowXml a => a (String, String) String
expandURI
    = forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Maybe String
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 :: forall s. IOStateArrow s String String
mkAbsURI
    = ( forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall s b. IOStateArrow s b String
getBaseURI ) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a (String, String) String
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getSchemeFromURI        = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
scheme
    where
    scheme :: URI -> String
scheme = forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getRegNameFromURI       = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
host
    where
    host :: URI -> String
host = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriRegName forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getPortFromURI          = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
port
    where
    port :: URI -> String
port = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
':') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriPort forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getUserInfoFromURI              = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
ui
    where
    ui :: URI -> String
ui = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'@') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriUserInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getPathFromURI          = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getQueryFromURI         = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
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 :: forall (a :: * -> * -> *). ArrowList a => a String String
getFragmentFromURI      = forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
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 :: forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
sel
    = forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
getPart)
      where
      getPart :: String -> Maybe String
getPart String
s = do
                  URI
uri <- String -> Maybe URI
parseURIReference' String
s
                  forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> String
sel URI
uri)

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