packages feed

rdf4h 3.1.0 → 3.1.1

raw patch · 4 files changed

+80/−70 lines, 4 filesdep +http-conduitdep +lifted-base

Dependencies added: http-conduit, lifted-base

Files

rdf4h.cabal view
@@ -1,5 +1,5 @@ name:            rdf4h-version:         3.1.0+version:         3.1.1 synopsis:        A library for RDF processing in Haskell description:   'RDF for Haskell' is a library for working with RDF in Haskell.@@ -55,6 +55,8 @@                  , parsers                  , mtl                  , network-uri >= 2.6+                 , lifted-base+                 , http-conduit   if impl(ghc < 7.6)     build-depends: ghc-prim   if !impl(ghc >= 8.0)
src/Text/RDF/RDF4H/ParserUtils.hs view
@@ -1,53 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Text.RDF.RDF4H.ParserUtils(-  _parseURL, justTriples,+  _parseURL,   Parser(..) ) where  import Data.RDF.Types -import Network.URI-import Network.HTTP-import Data.Char (intToDigit)+import Control.Exception.Lifted+import Network.HTTP.Conduit import Data.Text.Encoding (decodeUtf8)-import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T--- import qualified Data.Map as Map-import Data.Maybe (fromMaybe)  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 :: {- RDF rdf => -} String -> Either ParseFailure (RDF rdfImpl)+errResult :: String -> Either ParseFailure (RDF rdfImpl) errResult msg = Left (ParseFailure msg) --- | Keep the (Just t) triples (eliminating the Nothing comments), and unbox the--- triples, leaving a list of triples.-justTriples :: [Maybe Triple] -> [Triple]-justTriples = map (fromMaybe (error "ParserUtils.justTriples")) .-              filter (/= Nothing)---- | Parse contents at URL into an 'RDF'.-_parseURL :: {- Rdf rdf => -} (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))-_parseURL parseFunc url =-  maybe-    (return (Left (ParseFailure $ "Unable to parse URL: " ++ url)))-    doParse-    (parseURI url)-  where-    showRspCode (a, b, c) = map intToDigit [a, b, c]-    httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp-    doParse url' =-      simpleHTTP (request url') >>= \resp ->-        case resp of-          (Left e)    -> return (errResult $ "couldn't retrieve from URL: " ++ show url' ++ " [" ++ show e ++ "]")-          (Right res) -> case rspCode res of-                           (2, 0, 0) -> return $ parseFunc (decodeUtf8 (rspBody res))-                           _         -> return (errResult $ "couldn't retrieve from URL: " ++ httpError res)---- | Construct HTTP GET request.-request :: URI -> HTTPRequest B.ByteString-request uri = Request { rqURI = uri,-                        rqMethod = GET,-                        rqHeaders = [Header HdrConnection "close"],-                        rqBody = B.empty }+_parseURL :: (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))+_parseURL parseFunc url = do+  result <- Control.Exception.Lifted.try $ simpleHttp url+  case result of+    Left (ex::HttpException) ->+      case ex of+        (HttpExceptionRequest _req content) ->+          case content of+            ConnectionTimeout -> do+              return $ errResult "Connection timed out"+            _ -> return $ errResult ("HttpExceptionRequest content: " ++ show content)+        (InvalidUrlException{}) ->+          return $ errResult "Invalid URL exception"+    Right bs -> do+      let s = decodeUtf8 $ BS.toStrict bs+      return (parseFunc s)
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -17,12 +17,14 @@ import Control.Arrow.ArrowList (arrL) import Control.Arrow.ArrowState (ArrowState,nextState) import Control.Exception+import Data.Char import Data.List (isPrefixOf) import qualified Data.Map as Map (fromList) import Data.Maybe import Data.Typeable import Text.RDF.RDF4H.ParserUtils-import Data.RDF.Types (Rdf,RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate,uriValidateString)+import Data.RDF.IRI+import Data.RDF.Types (Rdf,RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate) import Data.Text (Text) import qualified Data.Text as T -- (Text,pack,unpack) import qualified Data.Text.IO as TIO@@ -30,6 +32,18 @@  -- TODO: write QuickCheck tests for XmlParser instance for RdfParser. +-- Useful HXT intro: http://adit.io/posts/2012-04-14-working_with_HTML_in_haskell.html++-- note on generating stack tracing with ghci+--+-- use 'traceStack'+--+-- then start ghci with+--+-- stack ghci --ghc-options "-fexternal-interpreter" --ghc-options "-prof"+--+-- then run the function you with to create a stack trace for.+ -- |'XmlParser' is an instance of 'RdfParser'. -- -- The 'BaseUrl' is used as the base URI within the document for@@ -136,16 +150,11 @@             rdf <- isElem <<< getChildren -< xml             bUrl <- arr (BaseUrl . T.pack) <<< ((getAttrValue0 "xml:base" <<< isElem <<< getChildren) `orElse` getAttrValue "transfer-URI") -< xml             prefixMap <- arr toPrefixMap <<< toAttrMap                  -< rdf-            triples <- (parseDescription' >. failOnEmptyList >>> unlistA) -< (bUrl,rdf)+            triples <- parseDescription' >. id -< (bUrl,rdf)             returnA -< mkRdf triples (Just bUrl) prefixMap   where toAttrMap = (getAttrl >>> (getName &&& (getChildren >>> getText))) >. id         toPrefixMap = PrefixMappings . Map.fromList . map (\(n, m) -> (T.pack (drop 6 n), T.pack m)) . filter (isPrefixOf "xmlns:" . fst) -        failOnEmptyList :: [b] -> [[b]]-        failOnEmptyList [] = []-        failOnEmptyList xs = [xs]-- -- |Read the initial state from an rdf element parseDescription' :: forall a. (ArrowXml a, ArrowState GParseState a) => a (BaseUrl, XmlTree) Triple parseDescription' = proc (bUrl, rdf) -> do@@ -367,14 +376,18 @@  getNodeIdTriple :: forall a. (ArrowXml a)                 => LParseState -> a XmlTree Triple-getNodeIdTriple state = nameToUNode &&& (getAttrValue "rdf:nodeID" >>> arr (bnode . T.pack))+getNodeIdTriple state = nameToUNode &&& (getAttrValue "rdf:nodeID" >>> (arrL (maybeToList . xmlName)) >>> arr (bnode . T.pack))     >>> arr (attachSubject (stateSubject state))  -- |Read a Node from the "rdf:about" property or generate a blank node mkNode :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Node mkNode state = choiceA [ hasAttr "rdf:about" :-> (attrExpandURI state "rdf:about" >>> mkUNode)                        , hasAttr "rdf:resource" :-> (attrExpandURI state "rdf:resource" >>> mkUNode)-                       , hasAttr "rdf:nodeID" :-> (getAttrValue "rdf:nodeID" >>> arr (bnode . T.pack))+                       -- , hasAttr "rdf:nodeID" :-> (getAttrValue "rdf:nodeID" >>> arr (bnode . T.pack))+                       --+                       -- rdfms-syntax-incomplete/error001.rdf says:+                       -- "The value of rdf:nodeID must match the XML Name production"+                       , hasAttr "rdf:nodeID" :-> (getAttrValue "rdf:nodeID" >>> (arrL (maybeToList . xmlName)) >>> arr (bnode . T.pack))                        , hasAttr "rdf:ID" :-> mkRelativeNode state                        , this :-> (validNodeElementName >>> mkBlankNode)                        ]@@ -415,25 +428,12 @@  my_expandURI :: ArrowXml a => a (String, String) String my_expandURI-    = arrL (maybeToList . uncurry my_expandURIString)--my_expandURIString :: String -> String -> Maybe String-my_expandURIString uri base =-  let absolute = if getPrefix uri == getPrefix base-                 then base ++ dropPrefix uri-                 else base ++ uri-  in uriValidateString absolute--dropPrefix :: String -> String-dropPrefix s = T.unpack $ T.drop 1 $ T.dropWhile (/= ':') (T.pack s)--getPrefix :: String -> String-getPrefix s =-  let pre = T.takeWhile (/= ':') (T.pack s)-  in T.unpack $-    if (not (T.null pre))-    then (pre `T.append` ":")-    else (T.pack "") +    = arrL (maybeToList . uncurry resolveIRIString)+      where+        resolveIRIString uri base =+          case resolveIRI (T.pack base) (T.pack uri) of+            Left _err -> Nothing+            Right x -> Just (T.unpack x)  -- |Make a UNode from an absolute string mkUNode :: forall a. (ArrowIf a) => a String Node@@ -443,9 +443,33 @@  -- |Make a UNode from a rdf:ID element, expanding relative URIs mkRelativeNode :: forall a. (ArrowXml a) => LParseState -> a XmlTree Node-mkRelativeNode s = (getAttrValue "rdf:ID" >>> arr (\x -> '#':x)) &&& baseUrl+mkRelativeNode s = (getAttrValue "rdf:ID" >>> (arrL (maybeToList . xmlName)) >>> arr (\x -> '#':x)) &&& baseUrl     >>> expandURI >>> arr (unode . T.pack)   where baseUrl = constA (case stateBaseUrl s of BaseUrl b -> T.unpack b)++-- The value of rdf:ID must match the XML Name production+--+-- https://docstore.mik.ua/orelly/xml/xmlnut/ch02_04.htm+-- http://www.informit.com/articles/article.aspx?p=27865&seqNum=4+--+-- see rdf-tests test rdfms-rdf-id-error004+xmlName :: String -> Maybe String+xmlName str = go [] str+  where+    go accum [] = Just accum+    go accum [s] =+      if isValid s+      then go (accum++[s]) []+      else Nothing+    go accum (s:ss) =+      if isValid s+      then go (accum++[s]) ss+      else Nothing+    isValid c = isAlphaNum c+                || '_' == c+                -- || '-' == c+                || '.' == c+                || ':' == c  -- |Make a literal node with the given type and content mkTypedLiteralNode :: Text -> String -> Node
testsuite/tests/W3C/RdfXmlTest.hs view
@@ -40,8 +40,7 @@ mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x  mfBaseURIXml :: BaseUrl--- mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/"-mfBaseURIXml = BaseUrl ""+mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/"  testParser :: XmlParser testParser = XmlParser (Just mfBaseURIXml) Nothing