module Text.XML.HXT.Arrow.XmlState.URIHandling
where
import Control.Arrow
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 )
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)
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
)
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
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
"/")
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
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
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
""
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
)
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
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
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
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'
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)
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
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
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
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
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
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
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
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
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)