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

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

-- | read the base URI from the globale state

getBaseURI              :: IOStateArrow s b String
getBaseURI :: IOStateArrow s b String
getBaseURI              = Selector XIOSysState String -> IOStateArrow s b String
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theBaseURI
                          IOStateArrow s b String
-> IOSLA (XIOState s) String String -> IOStateArrow s b String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( ( IOSLA (XIOState s) String String
forall s b. IOStateArrow s b String
getDefaultBaseURI
                              IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              IOSLA (XIOState s) String String
forall s. IOStateArrow s String String
setBaseURI
                              IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              IOSLA (XIOState s) String String
forall s b. IOStateArrow s b String
getBaseURI
                            )
                            IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                            (String -> Bool) -> IOSLA (XIOState s) String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA String -> Bool
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 :: IOStateArrow s String String
changeBaseURI           = IOStateArrow s String String
forall s. IOStateArrow s String String
mkAbsURI IOStateArrow s String String
-> IOStateArrow s String String -> IOStateArrow s String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOStateArrow s String String
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 :: String -> IOStateArrow s b String
setDefaultBaseURI String
base  = ( if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base
                            then (b -> IO String) -> IOStateArrow s b String
forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
arrIO b -> IO String
forall p. p -> IO String
getDir
                            else String -> IOStateArrow s b String
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
base
                          )
                          IOStateArrow s b String
-> IOSLA (XIOState s) String String -> IOStateArrow s b String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          Selector XIOSysState String -> IOSLA (XIOState s) String String
forall c s. Selector XIOSysState c -> IOStateArrow s c c
setSysVar Selector XIOSysState String
theDefaultBaseURI
                          IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          Int -> (String -> String) -> IOSLA (XIOState s) String String
forall b s. Int -> (b -> String) -> IOStateArrow s b b
traceValue Int
2 ((String
"setDefaultBaseURI: new default base URI is " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show)
    where
    getDir :: p -> IO String
getDir p
_            = do
                          String
cwd <- IO String
getCurrentDirectory
                          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"file://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalize String
cwd String -> String -> String
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 Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']
          Bool -> Bool -> Bool
||
          Char
d Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z']
                        = Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
win32ToUriChar String
wd'
    normalize String
wd'       = (Char -> String) -> String -> String
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 :: IOStateArrow s b String
getDefaultBaseURI       = Selector XIOSysState String -> IOStateArrow s b String
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar Selector XIOSysState String
theDefaultBaseURI            -- read default uri in system  state
                          IOStateArrow s b String
-> IOSLA (XIOState s) String String -> IOStateArrow s b String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( ( String -> IOSLA (XIOState s) String String
forall s b. String -> IOStateArrow s b String
setDefaultBaseURI String
""                  -- set the default uri in system state
                              IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                              IOSLA (XIOState s) String String
forall s b. IOStateArrow s b String
getDefaultBaseURI
                            )
                            IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
-> IOSLA (XIOState s) String String
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` (String -> Bool) -> IOSLA (XIOState s) String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA String -> Bool
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 :: IOStateArrow s b c -> IOStateArrow s b c
runInLocalURIContext IOStateArrow s b c
f  = Selector XIOSysState String
-> IOStateArrow s b c -> IOStateArrow s b c
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
      Maybe URI -> Maybe URI -> Maybe URI
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
      ( if Bool
unesc
        then String -> Maybe URI
parseURIReference String
uri'
        else Maybe URI
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      )
    where
    unesc :: Bool
unesc       = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUnescapedInURI (String -> Bool) -> String -> Bool
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'        = (Char -> String) -> String -> String
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'
      String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ URI -> String
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 :: a (String, String) String
expandURI
    = ((String, String) -> [String]) -> a (String, String) String
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String])
-> ((String, String) -> Maybe String)
-> (String, String)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> Maybe String)
-> (String, String) -> Maybe String
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 :: IOStateArrow s String String
mkAbsURI
    = ( IOStateArrow s String String
forall (a :: * -> * -> *) b. ArrowList a => a b b
this IOStateArrow s String String
-> IOStateArrow s String String
-> IOSLA (XIOState s) String (String, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& IOStateArrow s String String
forall s b. IOStateArrow s b String
getBaseURI ) IOSLA (XIOState s) String (String, String)
-> IOSLA (XIOState s) (String, String) String
-> IOStateArrow s String String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOSLA (XIOState s) (String, String) String
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 :: a String String
getSchemeFromURI        = (URI -> String) -> a String String
forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
scheme
    where
    scheme :: URI -> String
scheme = String -> String
forall a. [a] -> [a]
init (String -> String) -> (URI -> String) -> URI -> String
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 :: a String String
getRegNameFromURI       = (URI -> String) -> a String String
forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
host
    where
    host :: URI -> String
host = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriRegName (Maybe URIAuth -> String)
-> (URI -> Maybe URIAuth) -> URI -> String
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 :: a String String
getPortFromURI          = (URI -> String) -> a String String
forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
port
    where
    port :: URI -> String
port = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') (String -> String) -> (URI -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriPort (Maybe URIAuth -> String)
-> (URI -> Maybe URIAuth) -> URI -> String
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 :: a String String
getUserInfoFromURI              = (URI -> String) -> a String String
forall (a :: * -> * -> *).
ArrowList a =>
(URI -> String) -> a String String
getPartFromURI URI -> String
ui
    where
    ui :: URI -> String
ui = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (URI -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'@') (String -> String) -> (URI -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (URI -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" URIAuth -> String
uriUserInfo (Maybe URIAuth -> String)
-> (URI -> Maybe URIAuth) -> URI -> String
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 :: a String String
getPathFromURI          = (URI -> String) -> a String String
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 :: a String String
getQueryFromURI         = (URI -> String) -> a String String
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 :: a String String
getFragmentFromURI      = (URI -> String) -> a String String
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 :: (URI -> String) -> a String String
getPartFromURI URI -> String
sel
    = (String -> [String]) -> a String String
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String])
-> (String -> Maybe String) -> String -> [String]
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
                  String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> String
sel URI
uri)

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