IRI.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | An implementation of the RFC3987
--  [RFC3987]: http://www.ietf.org/rfc/rfc3987.txt
module Data.RDF.IRI
  ( IRI (..),
    IRIRef (..),
    Scheme (..),
    Authority (..),
    UserInfo (..),
    Host (..),
    Port (..),
    Path (..),
    IRIQuery (..),
    Fragment (..),
    IRIError (..),
    SchemaError (..),
    mkIRI,
    serializeIRI,
    parseIRI,
    parseRelIRI,
    validateIRI,
    resolveIRI,
    removeIRIFragment,
  )
where

#if MIN_VERSION_base(4,9,0)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#else
#endif
#else
#endif

#if MIN_VERSION_base(4,13,0)
import Data.Maybe (isJust)
#else
import Data.Maybe (maybe, isJust)
#endif

import Control.Applicative
import Control.Arrow (first, (&&&), (>>>))
import Control.Monad (guard)
import Data.Attoparsec.Text (Parser, (<?>))
import qualified Data.Attoparsec.Text as P
import Data.Char (isAlpha, isAlphaNum, isDigit, toLower, toUpper)
import Data.Functor
import Data.List (intersperse)
import Data.Text (Text)
import qualified Data.Text as T

-- | A serialized IRI representation.
newtype IRI = IRI {getIRI :: Text}
  deriving (Show, Eq)

-- | A detailed IRI representation with its components.
data IRIRef
  = IRIRef
      !(Maybe Scheme)
      !(Maybe Authority)
      !Path
      !(Maybe IRIQuery)
      !(Maybe Fragment)
  deriving (Show, Eq, Ord)

newtype Scheme = Scheme Text
  deriving (Show, Eq, Ord)

data Authority
  = Authority
      !(Maybe UserInfo)
      !Host
      !(Maybe Port)
  deriving (Show, Eq, Ord)

newtype UserInfo = UserInfo Text
  deriving (Show, Eq, Ord)

newtype Host = Host Text
  deriving (Show, Eq, Ord)

newtype Port = Port Int
  deriving (Show, Eq, Ord)

newtype Path = Path Text
  deriving (Show, Eq, Semigroup, Monoid, Ord)

newtype IRIQuery = IRIQuery Text
  deriving (Show, Eq, Semigroup, Ord)

instance Monoid IRIQuery where
  mempty = IRIQuery mempty

#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif

newtype Fragment = Fragment Text
  deriving (Show, Eq, Semigroup, Ord)

instance Monoid Fragment where
  mempty = Fragment mempty

#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif

data IRIError = InvalidIRI
  deriving (Show, Eq)

data SchemaError
  = -- | Scheme must start with an alphabet character
    NonAlphaLeading
  | -- | Subsequent characters in the schema were invalid
    InvalidChars
  | -- | Schemas must be followed by a colon
    MissingColon
  deriving (Show, Eq)

removeIRIFragment :: IRIRef -> IRIRef
removeIRIFragment (IRIRef s a p q _) = IRIRef s a p q Nothing

-- [TODO] use Builder
serializeIRI :: IRIRef -> Text
serializeIRI (IRIRef s a p q f) =
  mconcat
    [ maybe mempty scheme s,
      maybe mempty authority a,
      path p,
      maybe mempty query q,
      maybe mempty fragment f
    ]
  where
    scheme (Scheme s') = s' <> ":"
    authority (Authority u (Host h) p') =
      mconcat
        [ "//",
          maybe mempty userInfo u,
          h,
          maybe mempty port p'
        ]
    userInfo (UserInfo u) = u <> "@"
    port (Port p') = (":" <>) . T.pack . show $ p'
    path (Path p') = p'
    query (IRIQuery q') = "?" <> q'
    fragment (Fragment f') = "#" <> f'

mkIRI :: Text -> Either String IRI
mkIRI t = IRI . serializeIRI <$> parseIRI t

parseIRI :: Text -> Either String IRIRef
parseIRI = P.parseOnly $ iriParser <* (P.endOfInput <?> "Unexpected characters at the end")

parseRelIRI :: Text -> Either String IRIRef
parseRelIRI = P.parseOnly $ irelativeRefParser <* (P.endOfInput <?> "Unexpected characters at the end")

validateIRI :: Text -> Either String Text
validateIRI t = t <$ parseIRI t

-- | IRI parsing and resolution according to algorithm 5.2 from RFC3986
-- See: http://www.ietf.org/rfc/rfc3986.txt
-- [FIXME] Currently, this is a correct but naive implementation.
resolveIRI ::
  -- | Base URI
  Text ->
  -- | URI to resolve
  Text ->
  Either String Text
resolveIRI baseIri iri = serializeIRI <$> resolvedIRI
  where
    resolvedIRI = either (const resolvedRelativeIRI) resolveAbsoluteIRI (parseIRI iri)
    resolveAbsoluteIRI (IRIRef s a (Path p) q f) = return $ IRIRef s a (removeDotSegments p) q f
    resolvedRelativeIRI = do
      -- Parse as a relative IRI
      (IRIRef _ ra rp@(Path rp') rq rf) <- parseRelIRI iri
      -- Parse base IRI
      (IRIRef bs ba bp bq _) <- parseIRI baseIri
      let rIriWithoutAuth = resolveIriWithoutAuth rp rq rf bs ba bp bq
          rIriWithAuth = return (IRIRef bs ra (removeDotSegments rp') rq rf)
      maybe rIriWithoutAuth (const rIriWithAuth) ra
    resolveIriWithoutAuth rp rq rf bs ba bp bq =
      return
        $! if (rp == mempty)
          then maybe (IRIRef bs ba bp bq rf) (const (IRIRef bs ba bp rq rf)) rq
          else
            let (Path rp') = rp
             in if (T.head rp' == '/')
                  then IRIRef bs ba (removeDotSegments rp') rq rf
                  else IRIRef bs ba (removeDotSegments (merge ba bp rp)) rq rf
    removeDotSegments p = removeDotSegments' (T.split (== '/') p) mempty
    removeDotSegments' [] os = Path $ mconcat (intersperse "/" os)
    removeDotSegments' ["."] os = removeDotSegments' mempty (os <> [mempty])
    removeDotSegments' [".."] [] = removeDotSegments' mempty mempty
    removeDotSegments' [".."] os = removeDotSegments' mempty (init os <> [mempty])
    removeDotSegments' ss@[_] os = removeDotSegments' mempty (os <> ss)
    removeDotSegments' ("." : ss) os = removeDotSegments' ss os
    removeDotSegments' (".." : ss) [] = removeDotSegments' ss mempty
    removeDotSegments' (".." : ss) os@[""] = removeDotSegments' ss os
    removeDotSegments' (".." : ss) os = removeDotSegments' ss (init os)
    removeDotSegments' (s : ss) os = removeDotSegments' ss (os <> [s])
    merge ba (Path bp) (Path rp)
      | isJust ba && bp == mempty = "/" <> rp
      | otherwise = T.dropWhileEnd (/= '/') bp <> rp

-- IRI = scheme ":" ihier-part [ "?" iquery ] [ "#" ifragment ]
iriParser :: Parser IRIRef
iriParser = do
  scheme <- Just <$> schemeParser
  _ <- P.string ":" <?> "Missing colon after scheme"
  (authority, path) <- ihierPartParser
  query <- optional iqueryParser
  fragment <- optional ifragmentParser
  return (IRIRef scheme authority path query fragment)

-- ihier-part = "//" iauthority ipath-abempty
--            / ipath-absolute
--            / ipath-rootless
--            / ipath-empty
ihierPartParser :: Parser (Maybe Authority, Path)
ihierPartParser =
  iauthWithPathParser
    <|> ipathAbsoluteParser
    <|> ipathRootlessParser
    <|> ipathEmptyParser

-- IRI-reference = IRI / irelative-ref
-- [TODO]

-- absolute-IRI = scheme ":" ihier-part [ "?" iquery ]
-- [TODO]

-- irelative-ref = irelative-part [ "?" iquery ] [ "#" ifragment ]
irelativeRefParser :: Parser IRIRef
irelativeRefParser = do
  (authority, path) <- irelativePartParser
  query <- optional iqueryParser
  fragment <- optional ifragmentParser
  return (IRIRef Nothing authority path query fragment)

-- irelative-part = "//" iauthority ipath-abempty
--                / ipath-absolute
--                / ipath-noscheme
--                / ipath-empty
irelativePartParser :: Parser (Maybe Authority, Path)
irelativePartParser =
  iauthWithPathParser
    <|> ipathAbsoluteParser
    <|> ipathNoSchemeParser
    <|> ipathEmptyParser

-- iauthority = [ iuserinfo "@" ] ihost [ ":" port ]
iauthorityParser :: Parser Authority
iauthorityParser =
  Authority <$> optional (iuserInfoParser <* P.string "@")
    <*> ihostParser
    <*> optional (P.string ":" *> portParser)
    <?> "Authority"

-- iuserinfo = *( iunreserved / pct-encoded / sub-delims / ":" )
iuserInfoParser :: Parser UserInfo
iuserInfoParser = UserInfo . mconcat <$> P.many1 iuserInfoP
  where
    iuserInfoP = iunreservedP <|> pctEncodedParser <|> subDelimsP <|> P.string ":"

-- ihost = IP-literal / IPv4address / ireg-name
ihostParser :: Parser Host
ihostParser =
  Host <$> (ipLiteralParser <|> ipV4AddressParser <|> iregNameParser)
    <?> "Host"

-- ireg-name = *( iunreserved / pct-encoded / sub-delims )
iregNameParser :: Parser Text
iregNameParser = mconcat <$> P.many' (iunreservedP <|> pctEncodedParser <|> subDelimsP)

{-
ipath          = ipath-abempty   ; begins with "/" or is empty
                  / ipath-absolute  ; begins with "/" but not "//"
                  / ipath-noscheme  ; begins with a non-colon segment
                  / ipath-rootless  ; begins with a segment
                  / ipath-empty     ; zero characters
-}
-- [TODO]

-- ipath-abempty = *( "/" isegment )
ipathAbEmptyParser :: Parser Path
ipathAbEmptyParser = Path <$> ipathAbEmptyParser'

ipathAbEmptyParser' :: Parser Text
ipathAbEmptyParser' = mconcat <$> P.many' (mconcat <$> sequence [P.string "/", isegmentParser])

-- ipath-absolute = "/" [ isegment-nz *( "/" isegment ) ]
ipathAbsoluteParser :: Parser (Maybe Authority, Path)
ipathAbsoluteParser = (Nothing,) <$> (Path <$> ipathAbsoluteParser')

ipathAbsoluteParser' :: Parser Text
ipathAbsoluteParser' = mconcat <$> sequence [P.string "/", ipathRootlessParser']

-- ipath-noscheme = isegment-nz-nc *( "/" isegment )
ipathNoSchemeParser :: Parser (Maybe Authority, Path)
ipathNoSchemeParser = (Nothing,) <$> (Path <$> ipathNoSchemeParser')

ipathNoSchemeParser' :: Parser Text
ipathNoSchemeParser' = mconcat <$> sequence [isegmentNzNcParser, ipathAbEmptyParser']

-- ipath-rootless = isegment-nz *( "/" isegment )
ipathRootlessParser :: Parser (Maybe Authority, Path)
ipathRootlessParser = (Nothing,) <$> (Path <$> ipathRootlessParser')

ipathRootlessParser' :: Parser Text
ipathRootlessParser' = mconcat <$> sequence [isegmentNzParser, ipathAbEmptyParser']

-- ipath-empty = 0<ipchar>
ipathEmptyParser :: Parser (Maybe Authority, Path)
ipathEmptyParser = (Nothing, mempty) <$ ipathEmptyParser'

ipathEmptyParser' :: Parser Text
ipathEmptyParser' = P.string mempty <?> "Empty path"

-- isegment = *ipchar
isegmentParser :: Parser Text
isegmentParser = mconcat <$> (P.many' ipcharParser)

-- isegment-nz = 1*ipchar
isegmentNzParser :: Parser Text
isegmentNzParser = mconcat <$> (P.many1 ipcharParser)

-- isegment-nz-nc = 1*( iunreserved / pct-encoded / sub-delims / "@" )
--                ; non-zero-length segment without any colon ":"
isegmentNzNcParser :: Parser Text
isegmentNzNcParser = mconcat <$> (P.many1 _isegmentNzNcParser)
  where
    _isegmentNzNcParser = iunreservedP <|> pctEncodedParser <|> subDelimsP <|> P.string "@"

-- ipchar = iunreserved / pct-encoded / sub-delims / ":" / "@"
ipcharParser :: Parser Text
ipcharParser = iunreservedP <|> pctEncodedParser <|> subDelimsP <|> P.string ":" <|> P.string "@"

-- iquery = *( ipchar / iprivate / "/" / "?" )
iqueryParser :: Parser IRIQuery
iqueryParser = IRIQuery <$> iqueryParser'

iqueryParser' :: Parser Text
iqueryParser' =
  P.char '?' *> (mconcat <$> P.many' (ipcharParser <|> iprivateParser <|> P.string "/" <|> P.string "?"))
    <?> "Query"

-- ifragment = *( ipchar / "/" / "?" )
ifragmentParser :: Parser Fragment
ifragmentParser = Fragment <$> ifragmentParser'

ifragmentParser' :: Parser Text
ifragmentParser' =
  P.char '#' *> (mconcat <$> P.many' (ipcharParser <|> P.string "/" <|> P.string "?"))
    <?> "Fragment"

-- iunreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" / ucschar
iunreservedP :: Parser Text
iunreservedP = T.singleton <$> P.satisfy isIunreserved

isIunreserved :: Char -> Bool
isIunreserved c = isUnreserved c || isUcsChar c

-- ucschar = %xA0-D7FF / %xF900-FDCF / %xFDF0-FFEF
--         / %x10000-1FFFD / %x20000-2FFFD / %x30000-3FFFD
--         / %x40000-4FFFD / %x50000-5FFFD / %x60000-6FFFD
--         / %x70000-7FFFD / %x80000-8FFFD / %x90000-9FFFD
--         / %xA0000-AFFFD / %xB0000-BFFFD / %xC0000-CFFFD
--         / %xD0000-DFFFD / %xE1000-EFFFD
isUcsChar :: Char -> Bool
isUcsChar c =
  ('\x000A0' <= c && c <= '\x0D7FF')
    || ('\x0F900' <= c && c <= '\x0FDCF')
    || ('\x0FDF0' <= c && c <= '\x0FFEF')
    || ('\x10000' <= c && c <= '\x1FFFD')
    || ('\x20000' <= c && c <= '\x2FFFD')
    || ('\x30000' <= c && c <= '\x3FFFD')
    || ('\x40000' <= c && c <= '\x4FFFD')
    || ('\x50000' <= c && c <= '\x5FFFD')
    || ('\x60000' <= c && c <= '\x6FFFD')
    || ('\x70000' <= c && c <= '\x7FFFD')
    || ('\x80000' <= c && c <= '\x8FFFD')
    || ('\x90000' <= c && c <= '\x9FFFD')
    || ('\xA0000' <= c && c <= '\xAFFFD')
    || ('\xB0000' <= c && c <= '\xBFFFD')
    || ('\xC0000' <= c && c <= '\xCFFFD')
    || ('\xD0000' <= c && c <= '\xDFFFD')
    || ('\xE1000' <= c && c <= '\xEFFFD')

-- iprivate = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD
iprivateParser :: Parser Text
iprivateParser = T.singleton <$> P.satisfy isIPrivate

isIPrivate :: Char -> Bool
isIPrivate c =
  ('\x00E000' <= c && c <= '\x00F8FF')
    || ('\x0F0000' <= c && c <= '\x0FFFFD')
    || ('\x100000' <= c && c <= '\x10FFFD')

-- scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )
schemeParser :: Parser Scheme
schemeParser =
  -- Force lower case (RFC page 25)
  Scheme . T.map toLower <$> (T.cons <$> schemeHead <*> schemeRest)
  where
    schemeHead = P.satisfy isAlpha <?> "Scheme head"
    schemeRest = P.takeWhile isSchemeTailChar <?> "Scheme tail"
    isSchemeTailChar c =
      isAlphaNum c
        || c == '+'
        || c == '.'
        || c == '_'
        || c == '-'

-- port = *DIGIT
portParser :: Parser Port
portParser = Port <$> portParser'

portParser' :: Parser Int
portParser' = P.decimal <?> "Port"

-- IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
ipLiteralParser :: Parser Text
ipLiteralParser = P.string "[" *> (ipV6AddressParser <|> ipFutureParser) <* P.string "]"

-- IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
ipFutureParser :: Parser Text
ipFutureParser =
  mconcat
    <$> sequence
      [ P.string "v",
        P.takeWhile1 isHexaDigit,
        P.string ".",
        P.takeWhile1 isValidFinalChar
      ]
  where
    isValidFinalChar c = isUnreserved c || isSubDelims c || c == ':'

-- IPv6address =                            6( h16 ":" ) ls32
--             /                       "::" 5( h16 ":" ) ls32
--             / [               h16 ] "::" 4( h16 ":" ) ls32
--             / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
--             / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
--             / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
--             / [ *4( h16 ":" ) h16 ] "::"              ls32
--             / [ *5( h16 ":" ) h16 ] "::"              h16
--             / [ *6( h16 ":" ) h16 ] "::"
ipV6AddressParser :: Parser Text
ipV6AddressParser =
  do
    l <- leadingP
    t <- trailingP l
    joinParts l t
    <?> "IPV6"
  where
    leadingP = h16 `P.sepBy` ":"
    trailingP = (id &&& length) >>> \l -> ipNotElided l <|> ipElided l
    joinParts leading trailing = pure $ (T.intercalate ":" leading) <> trailing
    h16 = parseBetween 1 4 (P.takeWhile isHexaDigit)
    ipNotElided (leading, lengthL) =
      guard (lengthL == 7 && isDecOctet (last leading)) *> partialIpV4
        <|> (guard (lengthL == 8) $> mempty)
    ipElided (_, lengthL) = do
      guard $ lengthL <= 8
      elision <- P.string "::"
      trailing <- h16 `P.sepBy` ":"
      let lengthT = length trailing
      let lengthTotal = lengthL + lengthT
      guard $ lengthT < 8
      embeddedIpV4 <-
        guard (lengthT > 0 && lengthTotal < 7 && isDecOctet (last trailing)) *> partialIpV4
          <|> pure mempty
      pure $ mconcat [elision, (T.intercalate ":" trailing), embeddedIpV4]
    partialIpV4 = mconcat <$> sequence [dotP, decOctetP, dotP, decOctetP, dotP, decOctetP]

-- h16 = 1*4HEXDIG
-- [TODO]

-- ls32 = ( h16 ":" h16 ) / IPv4address
-- [TODO]

-- IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
ipV4AddressParser :: Parser Text
ipV4AddressParser = mconcat <$> sequence [decOctetP, dotP, decOctetP, dotP, decOctetP, dotP, decOctetP]

-- dec-octet = DIGIT                 ; 0-9
--           / %x31-39 DIGIT         ; 10-99
--           / "1" 2DIGIT            ; 100-199
--           / "2" %x30-34 DIGIT     ; 200-249
--           / "25" %x30-35          ; 250-255
decOctetP :: Parser Text
decOctetP = do
  -- [TODO] 1-liner ?
  s <- P.takeWhile1 isDigit
  guard (isDecOctet s)
  pure s

isDecOctet :: Text -> Bool
isDecOctet s = len > 0 && T.all isDigit s && (len < 3 || (len == 3 && s <= "255"))
  where
    len = T.length s

-- pct-encoded = "%" HEXDIG HEXDIG
pctEncodedParser :: Parser Text
pctEncodedParser =
  T.cons <$> P.char '%'
    <*> (T.pack . fmap toUpper <$> (P.count 2 (P.satisfy isHexaDigit)))
    <?> "Percent encoding"

-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
isUnreserved :: Char -> Bool
isUnreserved c =
  isAlphaNum c
    || c == '-'
    || c == '.'
    || c == '_'
    || c == '~'

-- reserved = gen-delims / sub-delims
-- [TODO]

-- gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@"

-- sub-delims     = "!" / "$" / "&" / "'" / "(" / ")"
--                / "*" / "+" / "," / ";" / "="
subDelimsP :: Parser Text
subDelimsP = T.singleton <$> P.satisfy isSubDelims

isSubDelims :: Char -> Bool
isSubDelims c = c `elem` ("!$&'()*+,;=" :: String)

-- "//" iauthority ipath-abempty
iauthWithPathParser :: Parser (Maybe Authority, Path)
iauthWithPathParser = do
  void (P.string "//")
  curry (first Just) <$> iauthorityParser <*> ipathAbEmptyParser

isHexaDigit :: Char -> Bool
isHexaDigit c =
  (isDigit c)
    || (c >= 'a' && c <= 'f')
    || (c >= 'A' && c <= 'F')

dotP :: Parser Text
dotP = P.string "."

parseBetween :: Int -> Int -> Parser Text -> Parser Text
parseBetween i j p = do
  s <- p
  let len = T.length s
  guard $ len >= i && len <= j
  return s