module Database.HSparql.Connection
( Database.HSparql.Connection.EndPoint
, BindingValue(..)
, selectQuery
, constructQuery
, askQuery
, updateQuery
, describeQuery
)
where
import Control.Monad
import Data.Maybe
import Network.HTTP
import Text.XML.Light
import Database.HSparql.QueryGenerator
import Text.RDF.RDF4H.TurtleParser
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
import Network.URI hiding (URI)
type EndPoint = String
data BindingValue = Bound RDF.Node
| Unbound
deriving (Show, Eq)
sparqlResult :: String -> QName
sparqlResult s = (unqual s) { qURI = Just "http://www.w3.org/2005/sparql-results#" }
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
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
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)
_ -> Unbound
langAttr :: QName
langAttr = blank_name { qName = "lang", qPrefix = Just "xml" }
parseAsk :: String -> Bool
parseAsk s
| (s' == "true" || s' == "yes") = True
| (s' == "false"|| s' == "no") = False
| otherwise = error $ "Unexpected Ask response: " ++ s
where s' = reverse $ dropWhile (=='\n') $ reverse s
parseUpdate :: String -> Bool
parseUpdate s
| s == "" = True
| otherwise = error $ "Unexpected Update response: " ++ s
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
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
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
return $ parseUpdate response
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
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
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"
request = Request { rqURI = fromJust $ parseURI uri
, rqHeaders = [h1,h2]
, rqMethod = GET
, rqBody = ""
}
response <- simpleHTTP request >>= getResponseBody
return $ RDF.parseString (TurtleParser Nothing Nothing) $ E.decodeUtf8 (B.pack response)