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

    {- |
       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              = 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 :: forall s b. 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 b c.
    IOSLA (XIOState s) b b
    -> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`
                                (String -> Bool) -> IOSLA (XIOState s) String String
    forall b. (b -> Bool) -> IOSLA (XIOState s) b b
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA String -> Bool
    forall a. [a] -> 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 :: forall s. 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 :: forall s b. String -> IOStateArrow s b String
    setDefaultBaseURI String
    base  = ( if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    base
                                then (b -> IO String) -> IOSLA (XIOState s) b String
    forall b c. (b -> IO c) -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) b c. ArrowIO a => (b -> IO c) -> a b c
    arrIO b -> IO String
    forall {p}. p -> IO String
    getDir
                                else String -> IOSLA (XIOState s) b String
    forall c b. c -> IOSLA (XIOState s) b c
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA String
    base
                              )
                              IOSLA (XIOState s) b String
    -> IOSLA (XIOState s) String String -> IOSLA (XIOState 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 a. a -> IO a
    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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 :: forall s b. 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 b c.
    IOSLA (XIOState s) b b
    -> IOSLA (XIOState s) b c -> IOSLA (XIOState s) b b
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when` (String -> Bool) -> IOSLA (XIOState s) String String
    forall b. (b -> Bool) -> IOSLA (XIOState s) b b
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA String -> Bool
    forall a. [a] -> 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 :: forall s b c. 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 a. Maybe a -> Maybe a -> Maybe a
    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 a. Maybe a
    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 a. a -> Maybe a
    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 :: forall (a :: * -> * -> *). ArrowXml a => a (String, String) String
    expandURI
        = ((String, String) -> [String]) -> a (String, String) String
    forall b c. (b -> [c]) -> a b c
    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 :: forall s. IOStateArrow s String String
    mkAbsURI
        = ( IOSLA (XIOState s) String String
    forall b. IOSLA (XIOState s) b b
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this IOSLA (XIOState s) String String
    -> IOSLA (XIOState s) String String
    -> IOSLA (XIOState s) String (String, String)
    forall b c c'.
    IOSLA (XIOState s) b c
    -> IOSLA (XIOState s) b c' -> IOSLA (XIOState s) b (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& IOSLA (XIOState s) String String
    forall s b. IOStateArrow s b String
    getBaseURI ) IOSLA (XIOState s) String (String, String)
    -> IOSLA (XIOState s) (String, 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) 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 :: forall (a :: * -> * -> *). ArrowList a => 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. HasCallStack => [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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *). ArrowList a => 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 :: forall (a :: * -> * -> *).
    ArrowList a =>
    (URI -> String) -> a String String
    getPartFromURI URI -> String
    sel
        = (String -> [String]) -> a String String
    forall b c. (b -> [c]) -> a b c
    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 a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (URI -> String
    sel URI
    uri)

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