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

module Text.RDF.RDF4H.ParserUtils
  ( Parser(..)
  , parseFromURL
  -- RDF
  , rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode
  , rdfSubjectNode, rdfPredicateNode, rdfObjectNode, rdfStatementNode
  , rdfTag, rdfID, rdfAbout, rdfParseType, rdfResource, rdfNodeID, rdfDatatype
  , rdfType, rdfLi, rdfListIndex
  , rdfDescription, rdfXmlLiteral
  , rdfAboutEach, rdfAboutEachPrefix, rdfBagID
  -- XML
  , xmlLang
  -- XSD
  , xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri
  -- for GHC 8.0 compatibility
#if MIN_VERSION_base(4,10,0)
#else
  , fromRight
#endif
  ) where

import Data.RDF.Types
import Data.RDF.Namespace

import Control.Exception.Lifted
import Network.HTTP.Conduit
import Data.Text.Encoding (decodeUtf8)
#if MIN_VERSION_base(4,9,0)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#else
#endif
#else
#endif
import qualified Data.ByteString.Lazy as BS
import           Data.Text (Text)
import qualified Data.Text as T

#if MIN_VERSION_base(4,10,0)
#else
fromRight :: b -> Either a b -> b
fromRight _ (Right b) = b
fromRight b _         = b
#endif

data Parser = Parsec | Attoparsec

-- | A convenience function for terminating a parse with a parse failure, using
-- the given error message as the message for the failure.
errResult :: String -> Either ParseFailure (RDF rdfImpl)
errResult :: forall rdfImpl. String -> Either ParseFailure (RDF rdfImpl)
errResult String
msg = ParseFailure -> Either ParseFailure (RDF rdfImpl)
forall a b. a -> Either a b
Left (String -> ParseFailure
ParseFailure String
msg)

parseFromURL :: (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))
parseFromURL :: forall rdfImpl.
(Text -> Either ParseFailure (RDF rdfImpl))
-> String -> IO (Either ParseFailure (RDF rdfImpl))
parseFromURL Text -> Either ParseFailure (RDF rdfImpl)
parseFunc String
url = do
  Either HttpException ByteString
result <- IO ByteString -> IO (Either HttpException ByteString)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
Control.Exception.Lifted.try (IO ByteString -> IO (Either HttpException ByteString))
-> IO ByteString -> IO (Either HttpException ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
simpleHttp String
url
  case Either HttpException ByteString
result of
    Left (HttpException
err :: HttpException) ->
      case HttpException
err of
        (HttpExceptionRequest Request
_req HttpExceptionContent
content) ->
          case HttpExceptionContent
content of
            HttpExceptionContent
ConnectionTimeout ->
              Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseFailure (RDF rdfImpl)
 -> IO (Either ParseFailure (RDF rdfImpl)))
-> Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a b. (a -> b) -> a -> b
$ String -> Either ParseFailure (RDF rdfImpl)
forall rdfImpl. String -> Either ParseFailure (RDF rdfImpl)
errResult String
"Connection timed out"
            HttpExceptionContent
_ -> Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseFailure (RDF rdfImpl)
 -> IO (Either ParseFailure (RDF rdfImpl)))
-> Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a b. (a -> b) -> a -> b
$ String -> Either ParseFailure (RDF rdfImpl)
forall rdfImpl. String -> Either ParseFailure (RDF rdfImpl)
errResult (String
"HttpExceptionRequest content: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
content)
        (InvalidUrlException{}) ->
          Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseFailure (RDF rdfImpl)
 -> IO (Either ParseFailure (RDF rdfImpl)))
-> Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a b. (a -> b) -> a -> b
$ String -> Either ParseFailure (RDF rdfImpl)
forall rdfImpl. String -> Either ParseFailure (RDF rdfImpl)
errResult String
"Invalid URL exception"
    Right ByteString
bs -> do
      let s :: Text
s = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
bs
      Either ParseFailure (RDF rdfImpl)
-> IO (Either ParseFailure (RDF rdfImpl))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either ParseFailure (RDF rdfImpl)
parseFunc Text
s)

rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node
rdfTypeNode :: Node
rdfTypeNode  = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"type"
rdfNilNode :: Node
rdfNilNode   = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"nil"
rdfFirstNode :: Node
rdfFirstNode = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"first"
rdfRestNode :: Node
rdfRestNode  = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"rest"

rdfSubjectNode, rdfPredicateNode, rdfObjectNode, rdfStatementNode :: Node
rdfSubjectNode :: Node
rdfSubjectNode   = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"subject"
rdfPredicateNode :: Node
rdfPredicateNode = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"predicate"
rdfObjectNode :: Node
rdfObjectNode    = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"object"
rdfStatementNode :: Node
rdfStatementNode = Text -> Node
UNode (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text
mkUri Namespace
rdf Text
"Statement"

-- Core terms
rdfTag, rdfID, rdfAbout, rdfParseType, rdfResource, rdfNodeID, rdfDatatype :: Text
rdfTag :: Text
rdfTag = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"RDF"
rdfID :: Text
rdfID = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"ID"
rdfAbout :: Text
rdfAbout = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"about"
rdfParseType :: Text
rdfParseType = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"parseType"
rdfResource :: Text
rdfResource = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"resource"
rdfNodeID :: Text
rdfNodeID = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"nodeID"
rdfDatatype :: Text
rdfDatatype = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"datatype"

rdfType, rdfLi, rdfListIndex :: Text
rdfType :: Text
rdfType = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"type"
rdfLi :: Text
rdfLi = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"li"
rdfListIndex :: Text
rdfListIndex = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"_"

rdfXmlLiteral, rdfDescription :: Text
rdfXmlLiteral :: Text
rdfXmlLiteral = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"XMLLiteral"
rdfDescription :: Text
rdfDescription = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"Description"

-- Old terms
rdfAboutEach, rdfAboutEachPrefix, rdfBagID :: Text
rdfAboutEach :: Text
rdfAboutEach = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"aboutEach"
rdfAboutEachPrefix :: Text
rdfAboutEachPrefix = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"aboutEachPrefix"
rdfBagID :: Text
rdfBagID = Namespace -> Text -> Text
mkUri Namespace
rdf Text
"bagID"

xmlLang :: Text
xmlLang :: Text
xmlLang = Namespace -> Text -> Text
mkUri Namespace
xml Text
"lang"

xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri :: Text
xsdIntUri :: Text
xsdIntUri     = Namespace -> Text -> Text
mkUri Namespace
xsd Text
"integer"
xsdDoubleUri :: Text
xsdDoubleUri  = Namespace -> Text -> Text
mkUri Namespace
xsd Text
"double"
xsdDecimalUri :: Text
xsdDecimalUri = Namespace -> Text -> Text
mkUri Namespace
xsd Text
"decimal"
xsdBooleanUri :: Text
xsdBooleanUri = Namespace -> Text -> Text
mkUri Namespace
xsd Text
"boolean"