{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

#if (__GLASGOW_HASKELL__ >= 802)
{-# LANGUAGE DerivingStrategies #-}
#endif

--------------------------------------------------------------------------------
--  See end of this file for licence information.
--------------------------------------------------------------------------------
-- |
--  Module      :  QName
--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2020, 2022 Douglas Burke
--  License     :  GPL V2
--
--  Maintainer  :  Douglas Burke
--  Stability   :  experimental
--  Portability :  CPP, DerivingStrategies, 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
#if (__GLASGOW_HASKELL__ >= 802)
      stock
#endif
      (LName -> LName -> Bool
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
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
Ord)

instance Show LName where
    show :: LName -> [Char]
show (LName Text
t) = forall a. Show a => a -> [Char]
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 :: [Char] -> LName
fromString [Char]
s = 
        forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"Invalid local name: " forall a. [a] -> [a] -> [a]
++ [Char]
s)) forall a b. (a -> b) -> a -> b
$
                  Text -> Maybe LName
newLName ([Char] -> Text
T.pack [Char]
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 forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAscii Char
c)) Text
l then forall a. Maybe a
Nothing else 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 :: [Char] -> QName
fromString [Char]
s = 
      forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"QName conversion given an invalid URI: " forall a. [a] -> [a] -> [a]
++ [Char]
s))
      ([Char] -> Maybe URI
parseURIReference [Char]
s 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 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 = 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 -> [Char]
show (QName InternedURI
u URI
_ LName
_) = [Char]
"<" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show InternedURI
u forall a. [a] -> [a] -> [a]
++ [Char]
">"

{-
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 :: [Char]
lstr   = Text -> [Char]
T.unpack Text
local
      uristr :: [Char]
uristr = forall a. Show a => a -> [Char]
show URI
ns forall a. [a] -> [a] -> [a]
++ [Char]
lstr
  in case [Char] -> Maybe URI
parseURIReference [Char]
uristr of
       Just URI
uri -> InternedURI -> URI -> LName -> QName
QName (forall t. Interned t => Uninterned t -> t
intern URI
uri) URI
ns LName
l
       Maybe URI
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to combine " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show URI
ns forall a. [a] -> [a] -> [a]
++ [Char]
" with " forall a. [a] -> [a] -> [a]
++ [Char]
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 :: [Char]
uf = URI -> [Char]
uriFragment URI
uri
      up :: [Char]
up = URI -> [Char]
uriPath URI
uri
      q0 :: Maybe QName
q0 = forall a. a -> Maybe a
Just 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 (forall t. Interned t => Uninterned t -> t
intern URI
uri)
  in case [Char]
uf of
       [Char]
"#"    -> Maybe QName
q0
       Char
'#':[Char]
xs -> URI -> LName -> QName
start (URI
uri {uriFragment :: [Char]
uriFragment = [Char]
"#"}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Text -> Maybe LName
newLName ([Char] -> Text
T.pack [Char]
xs)
       [Char]
""     -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') (forall a. [a] -> [a]
reverse [Char]
up) of
                   ([Char]
"",[Char]
_) -> Maybe QName
q0 -- path ends in / or is empty
                   ([Char]
_,[Char]
"") -> Maybe QName
q0 -- path contains no /
                   ([Char]
rlname,[Char]
rpath) -> 
                       URI -> LName -> QName
start (URI
uri {uriPath :: [Char]
uriPath = forall a. [a] -> [a]
reverse [Char]
rpath}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 
                       Text -> Maybe LName
newLName ([Char] -> Text
T.pack (forall a. [a] -> [a]
reverse [Char]
rlname))

       -- e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" 
       [Char]
_ -> 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
_) = 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 :: [Char] -> IO QName
qnameFromFilePath [Char]
fname = do
  [Char]
ipath <- [Char] -> IO [Char]
canonicalizePath [Char]
fname
  let ([Char]
dname, [Char]
lname) = [Char] -> ([Char], [Char])
splitFileName [Char]
ipath
      nsuri :: URI
nsuri = [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"file:" Maybe URIAuth
emptyAuth [Char]
dname [Char]
"" [Char]
""
      uri :: URI
uri = [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"file:" Maybe URIAuth
emptyAuth [Char]
ipath [Char]
"" [Char]
""
  case [Char]
lname of
    [Char]
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (forall t. Interned t => Uninterned t -> t
intern URI
nsuri) URI
nsuri LName
emptyLName
    [Char]
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (forall t. Interned t => Uninterned t -> t
intern URI
uri) URI
nsuri (Text -> LName
LName ([Char] -> Text
T.pack [Char]
lname))

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

--------------------------------------------------------------------------------
--
--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
--    2011, 2012, 2013, 2020, 2022 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
--
--------------------------------------------------------------------------------