{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  QName
--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2020 Douglas Burke
--  License     :  GPL V2
--
--  Maintainer  :  Douglas Burke
--  Stability   :  experimental
--  Portability :  OverloadedStrings
--
--  This module defines an algebraic datatype for qualified names (QNames),
--  which represents a 'URI' as the combination of a namespace 'URI'
--  and a local component ('LName'), which can be empty.
--
--  Although RDF supports using IRIs, the use of 'URI' here precludes this,
--  which means that, for instance, 'LName' only accepts a subset of valid
--  characters. There is currently no attempt to convert from an IRI into a URI.
--
--------------------------------------------------------------------------------

-- At present we support using URI references rather than forcing an absolute
-- URI. This is partly to support the existing tests (too lazy to resolve whether
-- the tests really should be using relative URIs in this case).

module Swish.QName
    ( QName
    , LName
    , emptyLName
    , newLName
    , getLName
    , newQName
    , qnameFromURI
    , getNamespace
    , getLocalName
    , getQNameURI
    , qnameFromFilePath
    )
    where

import Data.Char (isAscii)
import Data.Maybe (fromMaybe)
import Data.Interned (intern, unintern)
import Data.Interned.URI (InternedURI)
import Data.Ord (comparing)
import Data.String (IsString(..))

import Network.URI (URI(..), URIAuth(..), parseURIReference)

import System.Directory (canonicalizePath)
import System.FilePath (splitFileName)

import qualified Data.Text as T

------------------------------------------------------------
--  Qualified name
------------------------------------------------------------
--
--  These are RDF QNames rather than XML ones (as much as
--  RDF can claim to have them).
--


{-| A local name, which can be empty.

At present, the local name can not contain a space character and can only
contain ascii characters (those that match 'Data.Char.isAscii').

In version @0.9.0.3@ and earlier, the following characters were not
allowed in local names: \'#\', \':\', or \'/\' characters.

This is all rather experimental.
-}
newtype LName = LName T.Text
    deriving (LName -> LName -> Bool
(LName -> LName -> Bool) -> (LName -> LName -> Bool) -> Eq LName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LName -> LName -> Bool
$c/= :: LName -> LName -> Bool
== :: LName -> LName -> Bool
$c== :: LName -> LName -> Bool
Eq, Eq LName
Eq LName
-> (LName -> LName -> Ordering)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> LName)
-> (LName -> LName -> LName)
-> Ord LName
LName -> LName -> Bool
LName -> LName -> Ordering
LName -> LName -> LName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LName -> LName -> LName
$cmin :: LName -> LName -> LName
max :: LName -> LName -> LName
$cmax :: LName -> LName -> LName
>= :: LName -> LName -> Bool
$c>= :: LName -> LName -> Bool
> :: LName -> LName -> Bool
$c> :: LName -> LName -> Bool
<= :: LName -> LName -> Bool
$c<= :: LName -> LName -> Bool
< :: LName -> LName -> Bool
$c< :: LName -> LName -> Bool
compare :: LName -> LName -> Ordering
$ccompare :: LName -> LName -> Ordering
$cp1Ord :: Eq LName
Ord)

instance Show LName where
    show :: LName -> String
show (LName Text
t) = Text -> String
forall a. Show a => a -> String
show Text
t

-- | This is not total since attempting to convert a string
--   containing invalid characters will cause an error.
instance IsString LName where
    fromString :: String -> LName
fromString String
s = 
        LName -> Maybe LName -> LName
forall a. a -> Maybe a -> a
fromMaybe (String -> LName
forall a. HasCallStack => String -> a
error (String
"Invalid local name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)) (Maybe LName -> LName) -> Maybe LName -> LName
forall a b. (a -> b) -> a -> b
$
                  Text -> Maybe LName
newLName (String -> Text
T.pack String
s)

-- | The empty local name.
emptyLName :: LName
emptyLName :: LName
emptyLName = Text -> LName
LName Text
""

-- | Create a local name.
newLName :: T.Text -> Maybe LName
-- newLName l = if T.any (`elem` " #:/") l then Nothing else Just (LName l) -- 0.7.0.1 and earlier
-- newLName l = if T.any (\c -> c `elem` " #:/" || not (isAscii c)) l then Nothing else Just (LName l) -- 0.9.0.3 and earlier
newLName :: Text -> Maybe LName
newLName Text
l = if (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAscii Char
c)) Text
l then Maybe LName
forall a. Maybe a
Nothing else LName -> Maybe LName
forall a. a -> Maybe a
Just (Text -> LName
LName Text
l)

-- | Extract the local name.
getLName :: LName -> T.Text
getLName :: LName -> Text
getLName (LName Text
l) = Text
l

{-| 

A qualified name, consisting of a namespace URI
and the local part of the identifier, which can be empty.
The serialisation of a QName is formed by concatanating the
two components.

> Prelude> :set prompt "swish> "
> swish> :set -XOverloadedStrings
> swish> :m + Swish.QName
> swish> let qn1 = "http://example.com/" :: QName
> swish> let qn2 = "http://example.com/bob" :: QName
> swish> let qn3 = "http://example.com/bob/fred" :: QName
> swish> let qn4 = "http://example.com/bob/fred#x" :: QName
> swish> let qn5 = "http://example.com/bob/fred:joe" :: QName
> swish> map getLocalName [qn1, qn2, qn3, qn4, qn5]
> ["","bob","fred","x","fred:joe"]
> swish> getNamespace qn1
> http://example.com/
> swish> getNamespace qn2
> http://example.com/
> swish> getNamespace qn3
> http://example.com/bob/
> swish> getNamespace qn4
> http://example.com/bob/fred#

-}

{-
For now I have added in storing the actual URI
as well as the namespace component. This may or
may not be a good idea (space vs time saving).
-}

data QName = QName !InternedURI URI LName

-- | This is not total since it will fail if the input string is not a valid URI.
instance IsString QName where
  fromString :: String -> QName
fromString String
s = 
      QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe (String -> QName
forall a. HasCallStack => String -> a
error (String
"QName conversion given an invalid URI: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s))
      (String -> Maybe URI
parseURIReference String
s Maybe URI -> (URI -> Maybe QName) -> Maybe QName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= URI -> Maybe QName
qnameFromURI)

-- | Equality is determined by a case sensitive comparison of the               
-- URI.
instance Eq QName where
    QName
u1 == :: QName -> QName -> Bool
== QName
u2 = QName -> URI
getQNameURI QName
u1 URI -> URI -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> URI
getQNameURI QName
u2

-- | In @0.8.0.0@ the ordering now uses the ordering defined in
--   "Network.URI.Ord" rather than the @Show@
--   instance. This should make no difference unless a password
--   was included in the URI when using basic access authorization.
--
instance Ord QName where
    compare :: QName -> QName -> Ordering
compare = (QName -> URI) -> QName -> QName -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing QName -> URI
getQNameURI
  
-- | The format used to display the URI is @\<uri\>@, and does not
--   include the password if using basic access authorization.
instance Show QName where
    show :: QName -> String
show (QName InternedURI
u URI
_ LName
_) = String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ InternedURI -> String
forall a. Show a => a -> String
show InternedURI
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"

{-
The assumption in QName is that the validation done in creating
the local name is sufficient to ensure that the combined 
URI is syntactically valid. Is this true?
-}

-- | Create a new qualified name with an explicit local component.
--
newQName ::
    URI            -- ^ Namespace
    -> LName       -- ^ Local component
    -> QName
newQName :: URI -> LName -> QName
newQName URI
ns l :: LName
l@(LName Text
local) = 
  -- Until profiling shows that this is a time/space issue, we use
  -- the following code rather than trying to deconstruct the URI
  -- directly
  let lstr :: String
lstr   = Text -> String
T.unpack Text
local
      uristr :: String
uristr = URI -> String
forall a. Show a => a -> String
show URI
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lstr
  in case String -> Maybe URI
parseURIReference String
uristr of
       Just URI
uri -> InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern Uninterned InternedURI
URI
uri) URI
ns LName
l
       Maybe URI
_ -> String -> QName
forall a. HasCallStack => String -> a
error (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ String
"Unable to combine " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lstr
  
{-

old behavior

 splitQname "http://example.org/aaa#bbb" = ("http://example.org/aaa#","bbb")
 splitQname "http://example.org/aaa/bbb" = ("http://example.org/aaa/","bbb")
 splitQname "http://example.org/aaa/"    = ("http://example.org/aaa/","")

Should "urn:foo:bar" have a local name of "" or "foo:bar"? For now go
with the first option.

-}

-- | Create a new qualified name.
qnameFromURI :: 
    URI      -- ^ The URI will be deconstructed to find if it contains a local component.
    -> Maybe QName -- ^ The failure case may be removed.
qnameFromURI :: URI -> Maybe QName
qnameFromURI URI
uri =
  let uf :: String
uf = URI -> String
uriFragment URI
uri
      up :: String
up = URI -> String
uriPath URI
uri
      q0 :: Maybe QName
q0 = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ URI -> LName -> QName
start URI
uri LName
emptyLName
      start :: URI -> LName -> QName
start = InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern Uninterned InternedURI
URI
uri)
  in case String
uf of
       String
"#"    -> Maybe QName
q0
       Char
'#':String
xs -> URI -> LName -> QName
start (URI
uri {uriFragment :: String
uriFragment = String
"#"}) (LName -> QName) -> Maybe LName -> Maybe QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Text -> Maybe LName
newLName (String -> Text
T.pack String
xs)
       String
""     -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (ShowS
forall a. [a] -> [a]
reverse String
up) of
                   (String
"",String
_) -> Maybe QName
q0 -- path ends in / or is empty
                   (String
_,String
"") -> Maybe QName
q0 -- path contains no /
                   (String
rlname,String
rpath) -> 
                       URI -> LName -> QName
start (URI
uri {uriPath :: String
uriPath = ShowS
forall a. [a] -> [a]
reverse String
rpath}) (LName -> QName) -> Maybe LName -> Maybe QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 
                       Text -> Maybe LName
newLName (String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
rlname))

       -- e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" 
       String
_ -> Maybe QName
forall a. Maybe a
Nothing

-- | Return the URI of the namespace stored in the QName.
-- This does not contain the local component.
--
getNamespace :: QName -> URI
getNamespace :: QName -> URI
getNamespace (QName InternedURI
_ URI
ns LName
_) = URI
ns

-- | Return the local component of the QName.
getLocalName :: QName -> LName
getLocalName :: QName -> LName
getLocalName (QName InternedURI
_ URI
_ LName
l) = LName
l

-- | Returns the full URI of the QName (ie the combination of the
-- namespace and local components).
getQNameURI :: QName -> URI
getQNameURI :: QName -> URI
getQNameURI (QName InternedURI
u URI
_ LName
_) = InternedURI -> Uninterned InternedURI
forall t. Uninternable t => t -> Uninterned t
unintern InternedURI
u

{-|
Convert a filepath to a file: URI stored in a QName. If the
input file path is relative then the current working directory is used
to convert it into an absolute path.

If the input represents a directory then it *must* end in 
the directory separator - so for Posix systems use 
@\"\/foo\/bar\/\"@ rather than 
@\"\/foo\/bar\"@.

This has not been tested on Windows.
-}

{-
NOTE: not sure why I say directories should end in the path
seperator since

ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text"
"/Users/dburke/haskell/swish-text"
ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text/"
"/Users/dburke/haskell/swish-text"

-}

qnameFromFilePath :: FilePath -> IO QName
qnameFromFilePath :: String -> IO QName
qnameFromFilePath String
fname = do
  String
ipath <- String -> IO String
canonicalizePath String
fname
  let (String
dname, String
lname) = String -> (String, String)
splitFileName String
ipath
      nsuri :: URI
nsuri = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"file:" Maybe URIAuth
emptyAuth String
dname String
"" String
""
      uri :: URI
uri = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"file:" Maybe URIAuth
emptyAuth String
ipath String
"" String
""
  case String
lname of
    String
"" -> QName -> IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> IO QName) -> QName -> IO QName
forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern Uninterned InternedURI
URI
nsuri) URI
nsuri LName
emptyLName
    String
_  -> QName -> IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> IO QName) -> QName -> IO QName
forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern Uninterned InternedURI
URI
uri) URI
nsuri (Text -> LName
LName (String -> Text
T.pack String
lname))

emptyAuth :: Maybe URIAuth
emptyAuth :: Maybe URIAuth
emptyAuth = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> URIAuth
URIAuth String
"" String
"" String
""

--------------------------------------------------------------------------------
--
--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--    2011, 2012, 2013, 2020 Douglas Burke
--  All rights reserved.
--
--  This file is part of Swish.
--
--  Swish is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  Swish is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with Swish; if not, write to:
--    The Free Software Foundation, Inc.,
--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--
--------------------------------------------------------------------------------