diff --git a/Database/HSparql/Connection.hs b/Database/HSparql/Connection.hs --- a/Database/HSparql/Connection.hs +++ b/Database/HSparql/Connection.hs @@ -15,7 +15,7 @@ import Text.XML.Light import Database.HSparql.QueryGenerator import Text.RDF.RDF4H.TurtleParser -import Data.RDF +import qualified Data.RDF as RDF import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.ByteString.Char8 as B @@ -26,9 +26,9 @@ type EndPoint = String -- |Local representations of incoming XML results. -data BindingValue = Bound Data.RDF.Node -- ^RDF Node (UNode, BNode, LNode) +data BindingValue = Bound RDF.Node -- ^RDF Node (UNode, BNode, LNode) | Unbound -- ^Unbound result value - deriving (Show, Eq) + deriving (Show, Eq) -- |Base 'QName' for results with a SPARQL-result URI specified. sparqlResult :: String -> QName @@ -38,34 +38,34 @@ -- table storing the bindings for each variable in each row. structureContent :: String -> Maybe [[BindingValue]] structureContent s = - do e <- doc - return $ map (projectResult $ vars e) $ findElements (sparqlResult "result") e - where doc :: Maybe Element - doc = parseXMLDoc s + do e <- doc + return $ map (projectResult $ vars e) $ findElements (sparqlResult "result") e + where doc :: Maybe Element + doc = parseXMLDoc s - vars :: Element -> [String] - vars = mapMaybe (findAttr $ unqual "name") . findElements (sparqlResult "variable") + vars :: Element -> [String] + vars = mapMaybe (findAttr $ unqual "name") . findElements (sparqlResult "variable") - projectResult :: [String] -> Element -> [BindingValue] - projectResult vs e = map pVar vs - where pVar v = maybe Unbound (value . head . elChildren) $ filterElement (pred v) e - pred v e = isJust $ do a <- findAttr (unqual "name") e - guard $ a == v + projectResult :: [String] -> Element -> [BindingValue] + projectResult vs e = map pVar vs + where pVar v = maybe Unbound (value . head . elChildren) $ filterElement (pred_ v) e + pred_ v e' = isJust $ do a <- findAttr (unqual "name") e' + guard $ a == v - value :: Element -> BindingValue - value e = - case qName (elName e) of - "uri" -> Bound $ Data.RDF.unode $ (T.pack $ strContent e) - "literal" -> case findAttr (unqual "datatype") e of - Just dt -> Bound $ Data.RDF.lnode $ Data.RDF.typedL (T.pack $ strContent e) (T.pack dt) - Nothing -> case findAttr langAttr e of - Just lang -> Bound $ Data.RDF.lnode $ Data.RDF.plainLL (T.pack $ strContent e) (T.pack lang) - Nothing -> Bound $ Data.RDF.lnode $ Data.RDF.plainL (T.pack $ strContent e) - -- TODO: what about blank nodes? - _ -> Unbound + value :: Element -> BindingValue + value e = + case qName (elName e) of + "uri" -> Bound $ RDF.unode $ (T.pack $ strContent e) + "literal" -> case findAttr (unqual "datatype") e of + Just dt -> Bound $ RDF.lnode $ RDF.typedL (T.pack $ strContent e) (T.pack dt) + Nothing -> case findAttr langAttr e of + Just lang_ -> Bound $ RDF.lnode $ RDF.plainLL (T.pack $ strContent e) (T.pack lang_) + Nothing -> Bound $ RDF.lnode $ RDF.plainL (T.pack $ strContent e) + -- TODO: what about blank nodes? + _ -> Unbound - langAttr :: QName - langAttr = blank_name { qName = "lang", qPrefix = Just "xml" } + langAttr :: QName + langAttr = blank_name { qName = "lang", qPrefix = Just "xml" } -- |Parses the response from a SPARQL ASK query. Either "true" or "false" is expected parseAsk :: String -> Bool @@ -73,8 +73,7 @@ | (s' == "true" || s' == "yes") = True | (s' == "false"|| s' == "no") = False | otherwise = error $ "Unexpected Ask response: " ++ s - where - s' = reverse $ dropWhile (=='\n') $ reverse s + where s' = reverse $ dropWhile (=='\n') $ reverse s -- |Parses the response from a SPARQL UPDATE query. An empty body is expected parseUpdate :: String -> Bool @@ -86,74 +85,71 @@ -- 'Variable's in the 'SelectQuery' action. selectQuery :: Database.HSparql.Connection.EndPoint -> Query SelectQuery -> IO (Maybe [[BindingValue]]) selectQuery ep q = do - let uri = ep ++ "?" ++ urlEncodeVars [("query", createSelectQuery q)] - h1 = mkHeader HdrAccept "application/sparql-results+xml" - h2 = mkHeader HdrUserAgent "hsparql-client" - request = Request { rqURI = fromJust $ parseURI uri - , rqHeaders = [h1,h2] - , rqMethod = GET - , rqBody = "" - } - response <- simpleHTTP request >>= getResponseBody - return $ structureContent response + let uri = ep ++ "?" ++ urlEncodeVars [("query", createSelectQuery q)] + h1 = mkHeader HdrAccept "application/sparql-results+xml" + h2 = mkHeader HdrUserAgent "hsparql-client" + request = Request { rqURI = fromJust $ parseURI uri + , rqHeaders = [h1,h2] + , rqMethod = GET + , rqBody = "" + } + response <- simpleHTTP request >>= getResponseBody + return $ structureContent response -- |Connect to remote 'EndPoint' and find all possible bindings for the -- 'Variable's in the 'SelectQuery' action. askQuery :: Database.HSparql.Connection.EndPoint -> Query AskQuery -> IO Bool askQuery ep q = do - let uri = ep ++ "?" ++ urlEncodeVars [("query", createAskQuery q)] - hdr1 = Header HdrUserAgent "hsparql-client" - hdr2 = Header HdrAccept "text/plain" - hdr3 = Header HdrAccept "text/boolean" - hdr4 = Header HdrAcceptCharset "utf-8" - request = insertHeaders [hdr1,hdr2,hdr3,hdr4] (getRequest uri) - response <- simpleHTTP request >>= getResponseBody - return $ parseAsk response - + let uri = ep ++ "?" ++ urlEncodeVars [("query", createAskQuery q)] + hdr1 = Header HdrUserAgent "hsparql-client" + hdr2 = Header HdrAccept "text/plain" + hdr3 = Header HdrAccept "text/boolean" + hdr4 = Header HdrAcceptCharset "utf-8" + request = insertHeaders [hdr1,hdr2,hdr3,hdr4] (getRequest uri) + response <- simpleHTTP request >>= getResponseBody + return $ parseAsk response -- |Connect to remote 'EndPoint' and find all possible bindings for the -- 'Variable's in the 'SelectQuery' action. updateQuery :: Database.HSparql.Connection.EndPoint -> Query UpdateQuery -> IO Bool updateQuery ep q = do - let uri = ep - body = createUpdateQuery q - h1 = mkHeader HdrContentLength $ show (length body) - h2 = mkHeader HdrContentType "application/sparql-update" - h3 = mkHeader HdrUserAgent "hsparql-client" - request = Request { rqURI = fromJust $ parseURI uri - , rqHeaders = [h1,h2,h3] - , rqMethod = POST - , rqBody = body - } - response <- simpleHTTP request >>= getResponseBody + let uri = ep + body = createUpdateQuery q + h1 = mkHeader HdrContentLength $ show (length body) + h2 = mkHeader HdrContentType "application/sparql-update" + h3 = mkHeader HdrUserAgent "hsparql-client" + request = Request { rqURI = fromJust $ parseURI uri + , rqHeaders = [h1,h2,h3] + , rqMethod = POST + , rqBody = body + } + response <- simpleHTTP request >>= getResponseBody -- return $ structureContent response - return $ parseUpdate response - + return $ parseUpdate response -- |Connect to remote 'EndPoint' and construct 'TriplesGraph' from given -- 'ConstructQuery' action. /Provisional implementation/. -constructQuery :: (Rdf a) => Database.HSparql.Connection.EndPoint -> Query ConstructQuery -> IO (RDF a) +constructQuery :: (RDF.Rdf a) => Database.HSparql.Connection.EndPoint -> Query ConstructQuery -> IO (RDF.RDF a) constructQuery ep q = do - let uri = ep ++ "?" ++ urlEncodeVars [("query", createConstructQuery q)] - rdfGraph <- httpCallForRdf uri - case rdfGraph of - Left e -> error $ show e - Right graph -> return graph - + let uri = ep ++ "?" ++ urlEncodeVars [("query", createConstructQuery q)] + rdfGraph <- httpCallForRdf uri + case rdfGraph of + Left e -> error $ show e + Right graph -> return graph -- |Connect to remote 'EndPoint' and construct 'TriplesGraph' from given -- 'ConstructQuery' action. /Provisional implementation/. -describeQuery :: (Rdf a) => Database.HSparql.Connection.EndPoint -> Query DescribeQuery -> IO (RDF a) +describeQuery :: (RDF.Rdf a) => Database.HSparql.Connection.EndPoint -> Query DescribeQuery -> IO (RDF.RDF a) describeQuery ep q = do - let uri = ep ++ "?" ++ urlEncodeVars [("query", createDescribeQuery q)] - rdfGraph <- httpCallForRdf uri - case rdfGraph of - Left e -> error $ show e - Right graph -> return graph - + let uri = ep ++ "?" ++ urlEncodeVars [("query", createDescribeQuery q)] + rdfGraph <- httpCallForRdf uri + case rdfGraph of + Left e -> error $ show e + Right graph -> return graph + -- |Takes a generated uri and makes simple HTTP request, -- asking for RDF N3 serialization. Returns either 'ParseFailure' or 'RDF' -httpCallForRdf :: Rdf a => String -> IO (Either ParseFailure (RDF a)) +httpCallForRdf :: RDF.Rdf a => String -> IO (Either RDF.ParseFailure (RDF.RDF a)) httpCallForRdf uri = do let h1 = mkHeader HdrUserAgent "hsparql-client" h2 = mkHeader HdrAccept "text/turtle" @@ -163,4 +159,4 @@ , rqBody = "" } response <- simpleHTTP request >>= getResponseBody - return $ parseString (TurtleParser Nothing Nothing) $ E.decodeUtf8 (B.pack response) + return $ RDF.parseString (TurtleParser Nothing Nothing) $ E.decodeUtf8 (B.pack response) diff --git a/Database/HSparql/QueryGenerator.hs b/Database/HSparql/QueryGenerator.hs --- a/Database/HSparql/QueryGenerator.hs +++ b/Database/HSparql/QueryGenerator.hs @@ -1,85 +1,95 @@ +{-# LANGUAGE ExistentialQuantification #-} -- |The query generator DSL for SPARQL, used when connecting to remote -- endpoints. module Database.HSparql.QueryGenerator - ( -- * Creating Queries - createSelectQuery - , createConstructQuery - , createAskQuery - , createUpdateQuery - , createDescribeQuery - -- * Query Actions - , prefix - , var - , Database.HSparql.QueryGenerator.triple - , constructTriple - , askTriple - , updateTriple - , describeIRI - , optional - , union - , filterExpr + ( -- * Creating Queries + createSelectQuery + , createConstructQuery + , createAskQuery + , createUpdateQuery + , createDescribeQuery + -- * Query Actions + , prefix + , var + , Database.HSparql.QueryGenerator.triple + , mkPredicateObject + , constructTriple + , askTriple + , updateTriple + , describeIRI + , optional + , union + , filterExpr + , bind - -- ** Duplicate handling - , distinct - , reduced + -- ** Duplicate handling + , distinct + , reduced - -- ** Limit handling - , limit + -- ** Limit handling + , limit - -- ** Order handling - , orderNext - , orderNextAsc - , orderNextDesc + -- ** Order handling + , orderNext + , orderNextAsc + , orderNextDesc - -- ** Auxiliary - , (.:.) - , iriRef + -- ** Auxiliary + , (.:.) + , iriRef - -- * Term Manipulation + -- * Term Manipulation - -- ** Operations - , (.+.), (.-.), (.*.), (./.), (.&&.), (.||.) + -- ** Operations + , (.+.), (.-.), (.*.), (./.), (.&&.), (.||.) - -- ** Relations - , (.==.), (.!=.), (.<.), (.>.), (.<=.), (.>=.) + -- ** Relations + , (.==.), (.!=.), (.<.), (.>.), (.<=.), (.>=.) - -- ** Negation - , notExpr + -- ** Negation + , notExpr - -- ** Builtin Functions - , str - , lang - , langMatches - , datatype - , bound - , sameTerm - , isIRI - , isURI - , isBlank - , isLiteral - , regex, regexOpts + -- ** Builtin Functions + , str + , lang + , langMatches + , datatype + , bound + , sameTerm + , isIRI + , isURI + , isBlank + , isLiteral + , regex, regexOpts - -- * Printing Queries - , qshow + -- * Printing Queries + , qshow - -- * Types - , Query - , Variable - , VarOrNode(..) - , Pattern - , SelectQuery(..) - , ConstructQuery(..) - , AskQuery(..) - , UpdateQuery(..) - , DescribeQuery(..) - ) + -- * Types + , Query + , Variable + , VarOrNode(..) + , BlankNodePattern + , Pattern + , SelectQuery(..) + , ConstructQuery(..) + , AskQuery(..) + , UpdateQuery(..) + , DescribeQuery(..) + + -- * Classes + , TermLike (..) + , SubjectTermLike + , PredicateTermLike + , ObjectTermLike + ) where import Control.Monad.State import Data.List (intercalate) import qualified Data.Text as T -import Data.RDF +import qualified Data.RDF as RDF -- State monads @@ -94,50 +104,52 @@ -- |Execute a 'Select Query' action, returning the 'String' representation of the query. createSelectQuery :: Query SelectQuery -> String createSelectQuery q = execQuery specifyVars qshow - where specifyVars :: Query () - specifyVars = do query <- q - modify $ \s -> s { vars = queryVars query , queryType = SelectType } + where specifyVars :: Query () + specifyVars = do + query <- q + modify $ \s -> s { vars = queryVars query , queryType = SelectType } -- |Execute a 'Construct Query' action, returning the 'String' representation of the query. createConstructQuery :: Query ConstructQuery -> String createConstructQuery q = execQuery specifyType qshow - where specifyType :: Query () - specifyType = do - query <- q - modify $ \s -> s { constructTriples = queryConstructs query, queryType = ConstructType } + where specifyType :: Query () + specifyType = do + query <- q + modify $ \s -> s { constructTriples = queryConstructs query, queryType = ConstructType } -- |Execute a 'Ask Query' action, returning the 'String' representation of the query. createAskQuery :: Query AskQuery -> String createAskQuery q = execQuery specifyType qshow - where specifyType :: Query () - specifyType = do - query <- q - modify $ \s -> s { askTriples = queryAsk query, queryType = AskType } + where specifyType :: Query () + specifyType = do + query <- q + modify $ \s -> s { askTriples = queryAsk query, queryType = AskType } -- |Execute a 'Update Query' action, returning the 'String' representation of the query. createUpdateQuery :: Query UpdateQuery -> String createUpdateQuery q = execQuery specifyType qshow - where specifyType :: Query () - specifyType = do - query <- q - modify $ \s -> s { updateTriples = queryUpdate query, queryType = UpdateType } + where specifyType :: Query () + specifyType = do + query <- q + modify $ \s -> s { updateTriples = queryUpdate query, queryType = UpdateType } -- |Execute a 'Describe Query' action, returning the 'String' representation of the query. createDescribeQuery :: Query DescribeQuery -> String createDescribeQuery q = execQuery specifyType qshow - where specifyType :: Query () - specifyType = do - query <- q - modify $ \s -> s { describeURI = Just (queryDescribe query), queryType = DescribeType } + where specifyType :: Query () + specifyType = do + query <- q + modify $ \s -> s { describeURI = Just (queryDescribe query), queryType = DescribeType } -- Manipulate data within monad -- |Add a prefix to the query, given an IRI reference, and return it. prefix :: T.Text -> IRIRef -> Query Prefix prefix pre (AbsoluteIRI node) = do - let p = Prefix pre node - modify $ \s -> s { prefixes = p : prefixes s } - return p + let p = Prefix pre node + modify $ \s -> s { prefixes = p : prefixes s } + return p +prefix _ _ = error "prefix requires an absolute IRI" -- |Create and return a variable to the query, usable in later expressions. var :: Query Variable @@ -147,35 +159,34 @@ -- |Restrict the query to only results for which values match constants in this -- triple, or for which the variables can be bound. -triple :: (TermLike a, TermLike b, TermLike c) => a -> b -> c -> Query Pattern +triple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern triple a b c = do - let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) - modify $ \s -> s { pattern = appendPattern t (pattern s) } - return t - + let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) + modify $ \s -> s { pattern = appendPattern t (pattern s) } + return t -constructTriple :: (TermLike a, TermLike b, TermLike c) => a -> b -> c -> Query Pattern +constructTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern constructTriple a b c = do - let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) - modify $ \s -> s { constructTriples = appendTriple t (constructTriples s) } - return t + let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) + modify $ \s -> s { constructTriples = appendTriple t (constructTriples s) } + return t -askTriple :: (TermLike a, TermLike b, TermLike c) => a -> b -> c -> Query Pattern +askTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern askTriple a b c = do - let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) - modify $ \s -> s { askTriples = appendTriple t (askTriples s) } - return t + let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) + modify $ \s -> s { askTriples = appendTriple t (askTriples s) } + return t -updateTriple :: (TermLike a, TermLike b, TermLike c) => a -> b -> c -> Query Pattern +updateTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern updateTriple a b c = do - let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) -- TODO: should only allow terms - modify $ \s -> s { updateTriples = appendTriple t (updateTriples s) } - return t + let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) -- TODO: should only allow terms + modify $ \s -> s { updateTriples = appendTriple t (updateTriples s) } + return t describeIRI :: IRIRef -> Query IRIRef describeIRI newIri = do - modify $ \s -> s { describeURI = Just newIri } - return newIri + modify $ \s -> s { describeURI = Just newIri } + return newIri -- |Add optional constraints on matches. Variable bindings within the optional @@ -183,29 +194,35 @@ -- optional block. optional :: Query a -> Query Pattern optional q = do - -- Determine the patterns by executing the action on a blank QueryData, and - -- then pulling the patterns out from there. - let option = execQuery q $ OptionalGraphPattern . pattern - modify $ \s -> s { pattern = appendPattern option (pattern s) } - return option + -- Determine the patterns by executing the action on a blank QueryData, and + -- then pulling the patterns out from there. + let option = execQuery q $ OptionalGraphPattern . pattern + modify $ \s -> s { pattern = appendPattern option (pattern s) } + return option -- |Add a union structure to the query pattern. As with 'optional' blocks, -- variables must be defined prior to the opening of any block. union :: Query a -> Query b -> Query Pattern -union q1 q2 = do - let p1 = execQuery q1 pattern - p2 = execQuery q2 pattern - union' = UnionGraphPattern p1 p2 - modify $ \s -> s { pattern = appendPattern union' (pattern s) } - return union' +union q1 q2 = do + let p1 = execQuery q1 pattern + p2 = execQuery q2 pattern + union' = UnionGraphPattern p1 p2 + modify $ \s -> s { pattern = appendPattern union' (pattern s) } + return union' -- |Restrict results to only those for which the given expression is true. filterExpr :: (TermLike a) => a -> Query Pattern filterExpr e = do - let f = Filter (expr e) - modify $ \s -> s { pattern = appendPattern f (pattern s) } - return f + let f = Filter (expr e) + modify $ \s -> s { pattern = appendPattern f (pattern s) } + return f +bind :: Expr -> Variable -> Query Pattern +bind e v = do + let b = Bind (expr e) v + modify $ \s -> s { pattern = appendPattern b (pattern s) } + return b + -- Random auxiliary -- |Form a 'Node', with the 'Prefix' and reference name. @@ -235,7 +252,7 @@ -- |Alias of 'orderNextAsc'. orderNext :: (TermLike a) => a -> Query () -orderNext = orderNextAsc +orderNext = orderNextAsc -- |Order the results, after any previous ordering, based on the term, in -- ascending order. @@ -247,8 +264,8 @@ orderNextDesc :: (TermLike a) => a -> Query () orderNextDesc x = modify $ \s -> s { ordering = ordering s ++ [Desc $ expr x] } --- Permit variables and values to seemlessly be put into argument for 'triple' --- and similar functions +-- |Permit variables and values to seemlessly be put into argument for 'triple' +-- and similar functions class TermLike a where varOrTerm :: a -> VarOrTerm @@ -261,6 +278,13 @@ instance TermLike IRIRef where varOrTerm = Term . IRIRefTerm +instance TermLike BlankNodePattern where + varOrTerm [] = Term (BNode Nothing) + varOrTerm xs = BlankNodePattern' xs + + expr [] = error "FIXME: blank node expression" + expr _ = error "cannot use a blank node pattern as an expression" + instance TermLike Expr where varOrTerm = error "cannot use an expression as a term" expr = id @@ -270,23 +294,55 @@ expr = NumericExpr . NumericLiteralExpr instance TermLike T.Text where - varOrTerm = Term . RDFLiteralTerm . plainL + varOrTerm = Term . RDFLiteralTerm . RDF.plainL instance TermLike (T.Text, T.Text) where - varOrTerm (s, lang') = Term . RDFLiteralTerm $ plainLL s lang' + varOrTerm (s, lang') = Term . RDFLiteralTerm $ RDF.plainLL s lang' instance TermLike (T.Text, IRIRef) where - varOrTerm (s, ref) = Term . RDFLiteralTerm $ typedL s (getFQN ref) + varOrTerm (s, ref) = Term . RDFLiteralTerm $ RDF.typedL s (getFQN ref) instance TermLike Bool where varOrTerm = Term . BooleanLiteralTerm +instance TermLike RDF.Node where + varOrTerm n@(RDF.UNode _) = Term . IRIRefTerm . AbsoluteIRI $ n + varOrTerm (RDF.LNode lv) = Term . RDFLiteralTerm $ lv + varOrTerm (RDF.BNode i) = Term . BNode . Just $ i + varOrTerm (RDF.BNodeGen i) = Term . BNode . Just . T.pack . mconcat $ ["genid", show i] + instance TermLike VarOrNode where - varOrTerm (Var' v) = Var v - varOrTerm (RDFNode n@(UNode _)) = (Term . IRIRefTerm . AbsoluteIRI) n - varOrTerm (RDFNode (LNode lv)) = (Term . RDFLiteralTerm) lv - -- TODO: non-exhaustive: missing BNode, BNodeGen + varOrTerm (Var' v) = Var v + varOrTerm (RDFNode n) = varOrTerm n +-- |Restriction of TermLike to the role of subject. +class (TermLike a) => SubjectTermLike a + +instance SubjectTermLike IRIRef +instance SubjectTermLike Variable +instance SubjectTermLike BlankNodePattern + +-- |Restriction of TermLike to the role of predicate. +class (TermLike a) => PredicateTermLike a + +instance PredicateTermLike IRIRef +instance PredicateTermLike Variable + +-- |Restriction of TermLike to the role of object. +class (TermLike a) => ObjectTermLike a + +instance ObjectTermLike IRIRef +instance ObjectTermLike Variable +instance ObjectTermLike BlankNodePattern +instance ObjectTermLike Expr +instance ObjectTermLike Integer +instance ObjectTermLike T.Text +instance ObjectTermLike (T.Text, T.Text) +instance ObjectTermLike (T.Text, IRIRef) +instance ObjectTermLike Bool +instance ObjectTermLike VarOrNode +instance ObjectTermLike RDF.Node + -- Operations operation :: (TermLike a, TermLike b) => Operation -> a -> b -> Expr operation op x y = NumericExpr $ OperationExpr op (expr x) (expr y) @@ -429,7 +485,6 @@ } - -- Query representation class QueryShow a where -- |Convert most query-related types to a 'String', most importantly @@ -442,39 +497,57 @@ data Limit = NoLimit | Limit Int deriving (Show) -data Prefix = Prefix T.Text Node +data Prefix = Prefix T.Text RDF.Node deriving (Show) data Variable = Variable Int deriving (Show) -data IRIRef = AbsoluteIRI Node +data DynamicPredicate = forall a. (PredicateTermLike a, QueryShow a, Show a) => DynamicPredicate a +data DynamicObject = forall a. (ObjectTermLike a, QueryShow a, Show a) => DynamicObject a +type DynamicPredicateObject = (DynamicPredicate, DynamicObject) +type BlankNodePattern = [DynamicPredicateObject] + +instance Show DynamicPredicate where + show (DynamicPredicate a) = show a + +instance Show DynamicObject where + show (DynamicObject a) = show a + +mkPredicateObject :: (PredicateTermLike a, ObjectTermLike b, QueryShow a, QueryShow b, Show a, Show b) => a -> b -> DynamicPredicateObject +mkPredicateObject p o = (DynamicPredicate p, DynamicObject o) + +data IRIRef = AbsoluteIRI RDF.Node | PrefixedName Prefix T.Text deriving (Show) iriRef :: T.Text -> IRIRef -iriRef uri = AbsoluteIRI $ unode uri +iriRef uri = AbsoluteIRI $ RDF.unode uri getFQN :: IRIRef -> T.Text -getFQN (AbsoluteIRI (UNode n)) = n -getFQN (PrefixedName (Prefix _ (UNode n)) s) = T.append n s +getFQN (AbsoluteIRI (RDF.UNode n)) = n +getFQN (PrefixedName (Prefix _ (RDF.UNode n)) s) = T.append n s +-- FIXME +getFQN _ = error "getFQN: input not supported" --- Should support numeric literals, too +-- FIXME: Should support numeric literals, too data GraphTerm = IRIRefTerm IRIRef - | RDFLiteralTerm LValue + | RDFLiteralTerm RDF.LValue | NumericLiteralTerm Integer | BooleanLiteralTerm Bool + | BNode (Maybe T.Text) deriving (Show) data VarOrTerm = Var Variable | Term GraphTerm + | BlankNodePattern' BlankNodePattern deriving (Show) -- |Enables programmatic construction of triples where it is not known in -- advance which parts of the triple will be variables and which will be -- 'Node's. data VarOrNode = Var' Variable - | RDFNode Node + | RDFNode RDF.Node deriving (Show) data Operation = Add | Subtract | Multiply | Divide | And | Or @@ -503,8 +576,10 @@ data Pattern = QTriple VarOrTerm VarOrTerm VarOrTerm | Filter Expr + | Bind Expr Variable | OptionalGraphPattern GroupGraphPattern | UnionGraphPattern GroupGraphPattern GroupGraphPattern + data GroupGraphPattern = GroupGraphPattern [Pattern] data OrderBy = Asc Expr @@ -555,9 +630,13 @@ -- QueryShow instances -instance (QueryShow a) => QueryShow [a] where - qshow xs = unwords $ map qshow xs +instance QueryShow BlankNodePattern where + qshow [] = "[]" + qshow xs = intercalate ", " $ fmap qshow xs +instance QueryShow DynamicPredicateObject where + qshow (DynamicPredicate p, DynamicObject o) = mconcat ["[", qshow p, " ", qshow o, "]"] + instance QueryShow Duplicates where qshow NoLimits = "" qshow Distinct = "DISTINCT" @@ -567,15 +646,29 @@ qshow NoLimit = "" qshow (Limit n) = "Limit " ++ show n -instance QueryShow Node where - qshow (UNode n) = "<" ++ T.unpack n ++ ">" +instance QueryShow RDF.Node where + qshow (RDF.UNode n) = "<" ++ T.unpack n ++ ">" + qshow (RDF.BNode n) = "_:" ++ T.unpack n + qshow (RDF.BNodeGen i) = "_:genid" ++ show i + qshow (RDF.LNode n) = qshow n +instance QueryShow RDF.LValue where + qshow (RDF.PlainL lit) = T.unpack . T.concat $ ["\"", escapeSpecialChar lit, "\""] + qshow (RDF.PlainLL lit lang_) = T.unpack . T.concat $ ["\"", escapeSpecialChar lit, "\"@", lang_] + qshow (RDF.TypedL lit dtype) = T.unpack . T.concat $ ["\"", escapeSpecialChar lit, "\"^^<", dtype, ">"] + instance QueryShow Prefix where qshow (Prefix pre ref) = "PREFIX " ++ (T.unpack pre) ++ ": " ++ qshow ref +instance QueryShow [Prefix] where + qshow = unwords . fmap qshow + instance QueryShow Variable where qshow (Variable v) = "?x" ++ show v +instance QueryShow [Variable] where + qshow = unwords . fmap qshow + instance QueryShow IRIRef where qshow (AbsoluteIRI n) = qshow n qshow (PrefixedName (Prefix pre _) s) = (T.unpack pre) ++ ":" ++ (T.unpack s) @@ -584,22 +677,23 @@ qshow (Just r) = qshow r qshow Nothing = "" -instance QueryShow LValue where - qshow (PlainL s) = "\"" ++ (T.unpack $ escapeQuotes s) ++ "\"" - qshow (PlainLL s lang') = "\"" ++ (T.unpack $ escapeQuotes s) ++ "\"@" ++ (T.unpack lang') - qshow (TypedL s ref) = "\"" ++ (T.unpack $ escapeQuotes s) ++ "\"^^" ++ "<" ++ (T.unpack ref) ++ ">" - instance QueryShow GraphTerm where qshow (IRIRefTerm ref) = qshow ref qshow (RDFLiteralTerm s) = qshow s - qshow (BooleanLiteralTerm True) = show "true" - qshow (BooleanLiteralTerm False) = show "false" + qshow (BooleanLiteralTerm True) = show ("true" :: String) + qshow (BooleanLiteralTerm False) = show ("false" :: String) qshow (NumericLiteralTerm i) = show i + qshow (BNode Nothing) = "[]" + qshow (BNode (Just i)) = "_:" ++ T.unpack i instance QueryShow VarOrTerm where qshow (Var v) = qshow v qshow (Term t) = qshow t + qshow (BlankNodePattern' bn) = qshow bn +instance QueryShow [VarOrTerm] where + qshow = unwords . fmap qshow + instance QueryShow Operation where qshow Add = "+" qshow Subtract = "-" @@ -634,22 +728,26 @@ qshow RegexFunc = "REGEX" instance QueryShow Expr where - qshow (VarOrTermExpr vt) = qshow vt - qshow e = "(" ++ qshow' e ++ ")" - where qshow' (OrExpr es) = intercalate " || " $ map qshow es - qshow' (AndExpr es) = intercalate " && " $ map qshow es - qshow' (NegatedExpr e') = '!' : qshow e' - qshow' (RelationalExpr rel e1 e2) = qshow e1 ++ qshow rel ++ qshow e2 - qshow' (NumericExpr e') = qshow e' - qshow' (BuiltinCall f es) = qshow f ++ "(" ++ intercalate ", " (map qshow es) ++ ")" + qshow = qshow' + where qshow' (VarOrTermExpr vt) = qshow vt + qshow' (OrExpr es) = wrap $ intercalate " || " $ map qshow es + qshow' (AndExpr es) = wrap $ intercalate " && " $ map qshow es + qshow' (NegatedExpr e') = wrap $ '!' : qshow e' + qshow' (RelationalExpr rel e1 e2) = wrap $ qshow e1 ++ qshow rel ++ qshow e2 + qshow' (NumericExpr e') = wrap $ qshow e' + qshow' (BuiltinCall f es) = wrap $ qshow f ++ "(" ++ intercalate ", " (map qshow es) ++ ")" + wrap e = "(" ++ e ++ ")" instance QueryShow Pattern where - qshow (QTriple a b c) = qshow [a, b, c] ++ " ." - qshow (Filter e) = "FILTER " ++ qshow e ++ " ." - + qshow (QTriple a b c) = intercalate " " [qshow a, qshow b, qshow c, "."] + qshow (Filter e) = "FILTER " ++ qshow e ++ " ." + qshow (Bind e v) = "BIND(" ++ qshow e ++ " AS " ++ qshow v ++ ")" qshow (OptionalGraphPattern p) = "OPTIONAL " ++ qshow p qshow (UnionGraphPattern p1 p2) = qshow p1 ++ " UNION " ++ qshow p2 +instance QueryShow [Pattern] where + qshow = unwords . fmap qshow + instance QueryShow GroupGraphPattern where qshow (GroupGraphPattern ps) = "{" ++ qshow ps ++ "}" @@ -657,20 +755,15 @@ qshow (Asc e) = "ASC(" ++ qshow e ++ ")" qshow (Desc e) = "DESC(" ++ qshow e ++ ")" - instance QueryShow QueryForm where - qshow (SelectForm qd) = unwords + qshow (SelectForm qd) = unwords [ "SELECT" - , qshow (duplicates qd) - , qshow (vars qd) + , qshow (duplicates qd) + , qshow (vars qd) ] - qshow (ConstructForm qd) = "CONSTRUCT { " ++ qshow (constructTriples qd) ++ " }" - qshow (AskForm qd) = "ASK { " ++ qshow (askTriples qd) ++ " }" - qshow (UpdateForm qd) = "INSERT DATA { " ++ qshow (updateTriples qd) ++ " }" - qshow (DescribeForm qd) = "DESCRIBE " ++ qshow (describeURI qd) instance QueryShow QueryData where @@ -682,33 +775,43 @@ os -> "ORDER BY" : map qshow os query = case queryType qd of - SelectType -> + SelectType -> unwords [ qshow (prefixes qd) , qshow (SelectForm qd) , whereStmt , qshow (limits qd) ] - ConstructType -> + ConstructType -> unwords [ qshow (prefixes qd) , qshow (ConstructForm qd) , whereStmt ] - DescribeType -> + DescribeType -> unwords [ qshow (prefixes qd) , qshow (DescribeForm qd) , whereStmt ] - AskType -> + AskType -> unwords [ qshow (prefixes qd) , qshow (AskForm qd) ] - UpdateType -> + UpdateType -> unwords [ qshow (prefixes qd) , qshow (UpdateForm qd) ] + -- FIXME + TypeNotSet -> + error "instance QueryShow QueryData: TypeNotSet not supported." in query -- Internal utilities -escapeQuotes :: T.Text -> T.Text -escapeQuotes = T.replace "\"" "\\\"" +escapeSpecialChar :: T.Text -> T.Text +escapeSpecialChar = T.concatMap handleChar + -- FIXME: probably more cases to handle + where handleChar '\n' = "\n" + handleChar '\t' = "\t" + handleChar '\r' = "\r" + handleChar '"' = "\\\"" + handleChar '\\' = "\\\\" + handleChar c = T.singleton c diff --git a/hsparql.cabal b/hsparql.cabal --- a/hsparql.cabal +++ b/hsparql.cabal @@ -1,6 +1,6 @@ Name: hsparql Homepage: https://github.com/robstewart57/hsparql -Version: 0.3.1 +Version: 0.3.2 Synopsis: A SPARQL query generator and DSL, and a client to query a SPARQL server. Category: Database Description: @@ -34,6 +34,7 @@ , text , network-uri extensions: RankNTypes FlexibleInstances OverloadedStrings + ghc-options: -Wall -Wcompat test-suite test-hsparql type: exitcode-stdio-1.0 @@ -53,6 +54,7 @@ hs-source-dirs: Database, tests other-modules: Database.HSparql.ConnectionTest extensions: OverloadedStrings, FlexibleInstances + ghc-options: -Wall -Wcompat source-repository head type: git diff --git a/tests/AllTests.hs b/tests/AllTests.hs --- a/tests/AllTests.hs +++ b/tests/AllTests.hs @@ -4,38 +4,38 @@ import Database.HSparql.ConnectionTest -import Control.Concurrent (forkIO,threadDelay) -import Control.Exception.Base (bracket_) -import Network.HTTP.Types (status200, status500) +import Control.Concurrent (forkIO) +import Network.HTTP.Types (status200) import Network.Wai import Network.Wai.Handler.Warp (run) import Test.Framework +main :: IO () main = - do forkIO $ startServer + do _ <- forkIO $ startServer ropts <- interpretArgsOrExit [] defaultMainWithOpts tests ropts where tests = Database.HSparql.ConnectionTest.testSuite app :: Application app req respond = respond $ response req - where - response req = case rawQueryString req of - "?query=PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20SELECT%20%20%3Fx1%20WHERE%20%7B%3Fx0%20dbpedia%3Agenre%20dbprop%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D%20" - -> selectResponse - "?query=PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20ASK%20%7B%20%3Fx0%20dbprop%3Agenre%20dbpedia%3AWeb_browser%20.%20%7D" - -> askResponse - "?query=PREFIX%20example%3A%20%3Chttp%3A%2F%2Fwww.example.com%2F%3E%20PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20CONSTRUCT%20%7B%20%3Fx0%20example%3AhasName%20%3Fx1%20.%20%7D%20WHERE%20%7B%3Fx0%20dbprop%3Agenre%20dbpedia%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D" - -> constructResponse - "?query=PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20DESCRIBE%20dbpedia%3AEdinburgh%20WHERE%20%7B%7D" - -> describeResponse - otherwise - -> error $ "Unexpected URI: \n\n" ++ show (rawQueryString req) + where + response req_ = case rawQueryString req_ of + "?query=PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20SELECT%20%20%3Fx1%20WHERE%20%7B%3Fx0%20dbpedia%3Agenre%20dbprop%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D%20" + -> selectResponse + "?query=PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20ASK%20%7B%20%3Fx0%20dbprop%3Agenre%20dbpedia%3AWeb_browser%20.%20%7D" + -> askResponse + "?query=PREFIX%20example%3A%20%3Chttp%3A%2F%2Fwww.example.com%2F%3E%20PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20CONSTRUCT%20%7B%20%3Fx0%20example%3AhasName%20%3Fx1%20.%20%7D%20WHERE%20%7B%3Fx0%20dbprop%3Agenre%20dbpedia%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D" + -> constructResponse + "?query=PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20DESCRIBE%20dbpedia%3AEdinburgh%20WHERE%20%7B%7D" + -> describeResponse + raw_req + -> error $ "Unexpected URI: \n\n" ++ show raw_req - selectResponse = responseFile status200 [("Content-Type", "application/sparql-results+xml")] "tests/fixtures/sparql_select_response.xml" Nothing - askResponse = responseFile status200 [("Content-Type", "text/plain")] "tests/fixtures/sparql_ask_response.text" Nothing - constructResponse = responseFile status200 [("Content-Type", "text/turtle")] "tests/fixtures/sparql_construct_response.ttl" Nothing - describeResponse = responseFile status200 [("Content-Type", "text/turtle")] "tests/fixtures/sparql_describe_response.ttl" Nothing + selectResponse = responseFile status200 [("Content-Type", "application/sparql-results+xml")] "tests/fixtures/sparql_select_response.xml" Nothing + askResponse = responseFile status200 [("Content-Type", "text/plain")] "tests/fixtures/sparql_ask_response.text" Nothing + constructResponse = responseFile status200 [("Content-Type", "text/turtle")] "tests/fixtures/sparql_construct_response.ttl" Nothing + describeResponse = responseFile status200 [("Content-Type", "text/turtle")] "tests/fixtures/sparql_describe_response.ttl" Nothing startServer :: IO () diff --git a/tests/Database/HSparql/ConnectionTest.hs b/tests/Database/HSparql/ConnectionTest.hs --- a/tests/Database/HSparql/ConnectionTest.hs +++ b/tests/Database/HSparql/ConnectionTest.hs @@ -1,16 +1,16 @@ module Database.HSparql.ConnectionTest ( testSuite ) where -import Test.Framework (testGroup) +import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit import qualified Data.Map as Map -import qualified Data.Text as T import qualified Data.RDF as RDF import Database.HSparql.Connection import Database.HSparql.QueryGenerator +testSuite :: [Test.Framework.Test] testSuite = [ testGroup "Database.HSparql.Connection tests" [ testCase "selectQuery" test_selectQuery @@ -20,6 +20,7 @@ ] ] +test_selectQuery :: IO () test_selectQuery = let expectedBVars = Just [ [ Bound $ RDF.lnode $ RDF.plainLL "Kazehakase" "en" ] , [ Bound $ RDF.lnode $ RDF.plainLL "Netscape Browser" "en" ] @@ -38,33 +39,35 @@ x <- var name <- var - triple x (dbpprop .:. "genre") (resource .:. "Web_browser") - triple x (foaf .:. "name") name + _ <- triple x (dbpprop .:. "genre") (resource .:. "Web_browser") + _ <- triple x (foaf .:. "name") name return SelectQuery { queryVars = [name] } +test_askQuery :: IO () test_askQuery = do - bool <- askQuery endPoint query - assertBool "invalid" bool + bool <- askQuery endPoint query + assertBool "invalid" bool - where endPoint = "http://127.0.0.1:3000" - query = do - resource <- prefix "dbpedia" (iriRef "http://dbpedia.org/resource/") - dbprop <- prefix "dbprop" (iriRef "http://dbpedia.org/property/") + where endPoint = "http://127.0.0.1:3000" + query = do + resource <- prefix "dbpedia" (iriRef "http://dbpedia.org/resource/") + dbprop <- prefix "dbprop" (iriRef "http://dbpedia.org/property/") - x <- var - ask <- askTriple x (dbprop .:. "genre") (resource .:. "Web_browser") + x <- var + ask <- askTriple x (dbprop .:. "genre") (resource .:. "Web_browser") - return AskQuery { queryAsk = [ask] } + return AskQuery { queryAsk = [ask] } +test_constructQuery :: IO () test_constructQuery = - let expectedGraph :: RDF.TriplesList + let expectedGraph :: RDF.RDF RDF.TList expectedGraph = RDF.mkRdf expectedTriples Nothing (RDF.PrefixMappings Map.empty) expectedTriples = [ RDF.Triple (RDF.unode "http://dbpedia.org/resource/Kazehakase") (RDF.unode "http://www.example.com/hasName") (RDF.lnode $ RDF.plainLL "Kazehakase" "en") ] in do - graph <- constructQuery endPoint query :: IO RDF.TriplesList + graph <- constructQuery endPoint query :: IO (RDF.RDF RDF.TList) assertBool "RDF does not include the constructed triple" $ RDF.isIsomorphic expectedGraph graph where endPoint = "http://127.0.0.1:3000" @@ -78,15 +81,16 @@ name <- var construct <- constructTriple x (example .:. "hasName") name - triple x (dbpprop .:. "genre") (resource .:. "Web_browser") - triple x (foaf .:. "name") name + _ <- triple x (dbpprop .:. "genre") (resource .:. "Web_browser") + _ <- triple x (foaf .:. "name") name return ConstructQuery { queryConstructs = [construct] } +test_describeQuery :: IO () test_describeQuery = let expectedNode = RDF.unode "http://dbpedia.org/resource/Edinburgh" in do - graph <- describeQuery endPoint query :: IO RDF.TriplesList + graph <- describeQuery endPoint query :: IO (RDF.RDF RDF.TList) assertBool "RDF does not include the required node" $ RDF.rdfContainsNode graph expectedNode where endPoint = "http://127.0.0.1:3000"