From 906669784eebc833366c1a6d348eacca7d5cc964 Mon Sep 17 00:00:00 2001 From: defanor Date: Thu, 22 Feb 2018 00:51:57 +0300 Subject: Add a few statements and streams functions --- Redland/LowLevel.hs | 73 ++++++++++++++++++++++ Redland/MidLevel.hs | 172 +++++++++++++++++++++++++++++++++++++++++++--------- Redland/Util.hs | 108 ++++++++++++++++++++++++++------- 3 files changed, 303 insertions(+), 50 deletions(-) diff --git a/Redland/LowLevel.hs b/Redland/LowLevel.hs index 388a387..07f20af 100644 --- a/Redland/LowLevel.hs +++ b/Redland/LowLevel.hs @@ -135,6 +135,11 @@ foreign import ccall "librdf_free_node" foreign import ccall "redland.h &librdf_free_node" p_librdf_free_node :: FinalizerPtr RedlandNode +foreign import ccall "librdf_new_node_from_node" + librdf_new_node_from_node + :: Ptr RedlandNode + -- ^ old node + -> IO (Ptr RedlandNode) foreign import ccall "librdf_new_node_from_blank_identifier" librdf_new_node_from_blank_identifier :: Ptr RedlandWorld @@ -230,6 +235,20 @@ foreign import ccall "librdf_parser_parse_string_into_model" -> IO CInt -- ^ non-zero on failure +-- librdf_parser_guess_name always fails, skipping it + +foreign import ccall "librdf_parser_guess_name2" + librdf_parser_guess_name2 + :: Ptr RedlandWorld + -> CString + -- ^ MIME type or NULL + -> CString + -- ^ content buffer or NULL + -> CString + -- ^ content identifier or NULL + -> IO CString + -- ^ parser name or NULL + -- * Querying @@ -313,6 +332,50 @@ foreign import ccall "librdf_free_statement" foreign import ccall "redland.h &librdf_free_statement" p_librdf_free_statement :: FinalizerPtr RedlandStatement +-- | "The node objects become owned by the new statement (or freed on +-- error)." +foreign import ccall "librdf_new_statement_from_nodes" + librdf_new_statement_from_nodes + :: Ptr RedlandWorld + -> Ptr RedlandNode + -> Ptr RedlandNode + -> Ptr RedlandNode + -> IO (Ptr RedlandStatement) +foreign import ccall "librdf_new_statement_from_statement" + librdf_new_statement_from_statement + :: Ptr RedlandStatement + -> IO (Ptr RedlandStatement) + +foreign import ccall "librdf_statement_get_subject" + librdf_statement_get_subject + :: Ptr RedlandStatement + -> IO (Ptr RedlandNode) + -- ^ the returned node is shared, should be copied +foreign import ccall "librdf_statement_set_subject" + librdf_statement_set_subject + :: Ptr RedlandStatement + -> Ptr RedlandNode + -- ^ becomes owned by the statement + -> IO () +foreign import ccall "librdf_statement_get_predicate" + librdf_statement_get_predicate + :: Ptr RedlandStatement + -> IO (Ptr RedlandNode) +foreign import ccall "librdf_statement_set_predicate" + librdf_statement_set_predicate + :: Ptr RedlandStatement + -> Ptr RedlandNode + -> IO () +foreign import ccall "librdf_statement_get_object" + librdf_statement_get_object + :: Ptr RedlandStatement + -> IO (Ptr RedlandNode) +foreign import ccall "librdf_statement_set_object" + librdf_statement_set_object + :: Ptr RedlandStatement + -> Ptr RedlandNode + -> IO () + -- * Triple stores @@ -356,6 +419,16 @@ foreign import ccall "librdf_free_stream" foreign import ccall "redland.h &librdf_free_stream" p_librdf_free_stream :: FinalizerPtr RedlandStream +foreign import ccall "librdf_stream_end" + librdf_stream_end :: Ptr RedlandStream -> IO CInt +foreign import ccall "librdf_stream_next" + librdf_stream_next :: Ptr RedlandStream -> IO CInt +foreign import ccall "librdf_stream_get_object" + librdf_stream_get_object + :: Ptr RedlandStream + -> IO (Ptr RedlandStatement) + -- ^ a shared statement, should be copied + -- * URI diff --git a/Redland/MidLevel.hs b/Redland/MidLevel.hs index f8aa546..fb3367a 100644 --- a/Redland/MidLevel.hs +++ b/Redland/MidLevel.hs @@ -6,8 +6,9 @@ Portability : non-portable (GHC extensions are used) Mid-level bindings: using Haskell naming conventions, common Haskell types, -'ForeignPtr' with finalizers, exceptions. Closely follows the original -API otherwise. +'ForeignPtr' with finalizers, exceptions, copied structures (as +opposed to the shared ones, as nodes in statement-related functions in +the C API). Closely follows the original API otherwise. -} @@ -16,9 +17,11 @@ module Redland.MidLevel where import Foreign import Foreign.C import Control.Exception +import Control.Monad import Redland.LowLevel + -- * Exceptions data RedlandException = InitializationException @@ -63,7 +66,7 @@ perform a = do -- | Initializes a Redland object, performs an action over it, makes -- sure to call 'finalizeForeignPtr' afterwards. withNew :: Initializer a -> (ForeignPtr a -> IO b) -> IO b -withNew i f = bracket i finalizeForeignPtr f +withNew i = bracket i finalizeForeignPtr -- | An abstraction to use with 'withCString' and 'withForeignPtr'. withNullablePtr :: (a -> (Ptr b -> c) -> c) -> Maybe a -> (Ptr b -> c) -> c @@ -73,12 +76,15 @@ withNullablePtr f (Just x) a = f x a -- | Checks whether a 'CString' is NULL, frees if it not, returns a -- Haskell 'String'. maybeCString :: CString -> IO (Maybe String) -maybeCString cStr +maybeCString cStr = do + r <- maybeSharedCString cStr + free cStr + pure r + +maybeSharedCString :: CString -> IO (Maybe String) +maybeSharedCString cStr | cStr == nullPtr = pure Nothing - | otherwise = do - r <- peekCString cStr - free cStr - pure $ pure r + | otherwise = Just <$> peekCString cStr -- | Like 'maybeCString', but requires a string to be there, and -- throws 'StringOperationException' if it isn't. @@ -134,8 +140,7 @@ hashGet :: ForeignPtr RedlandHash -> IO (Maybe String) hashGet hash key = withForeignPtr hash $ \hash' -> - withCString key $ \key' -> - librdf_hash_get hash' key' >>= maybeCString + withCString key $ librdf_hash_get hash' >=> maybeCString hashGetDel :: ForeignPtr RedlandHash -- ^ hash @@ -144,8 +149,7 @@ hashGetDel :: ForeignPtr RedlandHash -> IO (Maybe String) hashGetDel hash key = withForeignPtr hash $ \hash' -> - withCString key $ \key' -> - librdf_hash_get_del hash' key' >>= maybeCString + withCString key $ librdf_hash_get_del hash' >=> maybeCString -- * RDF Graph (librdf_model) @@ -214,6 +218,11 @@ redlandNode world = withForeignPtr world $ \world' -> initialize (librdf_new_node world') p_librdf_free_node +nodeFromNode :: ForeignPtr RedlandNode -> Initializer RedlandNode +nodeFromNode node = + withForeignPtr node $ \node' -> + initialize (librdf_new_node_from_node node') p_librdf_free_node + nodeFromBlankIdentifier :: ForeignPtr RedlandWorld -> Maybe String -> Initializer RedlandNode @@ -269,13 +278,13 @@ nodeFromURIString world uriStr = nodeGetBlankIdentifier :: ForeignPtr RedlandNode -> IO String nodeGetBlankIdentifier node = - withForeignPtr node $ \node' -> - librdf_node_get_blank_identifier node' >>= justSharedCString + withForeignPtr node $ + librdf_node_get_blank_identifier >=> justSharedCString nodeGetLiteralValue :: ForeignPtr RedlandNode -> IO String nodeGetLiteralValue node = - withForeignPtr node $ \node' -> - librdf_node_get_literal_value node' >>= justSharedCString + withForeignPtr node $ + librdf_node_get_literal_value >=> justSharedCString nodeGetURI :: ForeignPtr RedlandNode -> Initializer RedlandURI nodeGetURI node = @@ -297,8 +306,7 @@ nodeIsResource node = nodeToString :: ForeignPtr RedlandNode -> IO String nodeToString node = - withForeignPtr node $ \node' -> - librdf_node_to_string node' >>= justCString + withForeignPtr node $ librdf_node_to_string >=> justCString -- * Parsers @@ -336,6 +344,21 @@ parseStringIntoModel parser str uri model = withForeignPtr model $ \model' -> perform $ librdf_parser_parse_string_into_model parser' str' uri' model' +parserGuessName2 :: ForeignPtr RedlandWorld + -> Maybe String + -- ^ MIME type + -> Maybe String + -- ^ content + -> Maybe String + -- ^ content identifier + -> IO (Maybe String) +parserGuessName2 world mime content contentId = + withForeignPtr world $ \world' -> + withNullablePtr withCString mime $ \mime' -> + withNullablePtr withCString content $ \content' -> + withNullablePtr withCString contentId $ + librdf_parser_guess_name2 world' mime' content' >=> maybeSharedCString + -- * Querying @@ -363,18 +386,17 @@ redlandQuery world lang langURI query baseURI = queryResultsGetCount :: ForeignPtr RedlandQueryResults -> IO Int queryResultsGetCount results = - withForeignPtr results $ \results' -> - fromIntegral <$> librdf_query_results_get_count results' + withForeignPtr results $ fmap fromIntegral . librdf_query_results_get_count -queryResultsNext :: ForeignPtr RedlandQueryResults -> IO Bool +queryResultsNext :: ForeignPtr RedlandQueryResults + -> IO Bool + -- ^ 'True' if it's not finished. queryResultsNext results = - withForeignPtr results $ \results' -> - (== 0) <$> librdf_query_results_next results' + withForeignPtr results $ fmap (== 0) . librdf_query_results_next queryResultsFinished :: ForeignPtr RedlandQueryResults -> IO Bool queryResultsFinished results = - withForeignPtr results $ \results' -> - (/= 0) <$> librdf_query_results_finished results' + withForeignPtr results $ fmap (/= 0) . librdf_query_results_finished -- | Acts as a 'RedlandNode' initializer. queryResultsGetBindingValue :: ForeignPtr RedlandQueryResults @@ -408,8 +430,8 @@ queryResultsGetBindingValueByName results name = queryResultsGetBindingsCount :: ForeignPtr RedlandQueryResults -> IO Int queryResultsGetBindingsCount results = - withForeignPtr results $ \results' -> - fromIntegral <$> librdf_query_results_get_bindings_count results' + withForeignPtr results $ + fmap fromIntegral . librdf_query_results_get_bindings_count -- | Acts as a 'RedlandQueryResults' initializer. queryExecute :: ForeignPtr RedlandQuery @@ -428,6 +450,78 @@ redlandStatement world = withForeignPtr world $ \world' -> initialize (librdf_new_statement world') p_librdf_free_statement +statementFromNodes :: ForeignPtr RedlandWorld + -> Maybe (ForeignPtr RedlandNode) + -- ^ subject + -> Maybe (ForeignPtr RedlandNode) + -- ^ predicate + -> Maybe (ForeignPtr RedlandNode) + -- ^ object + -> Initializer RedlandStatement +statementFromNodes world subject predicate object = + withForeignPtr world $ \world' -> + withNullablePtr withForeignPtr subject $ \subject' -> + withNullablePtr withForeignPtr predicate $ \predicate' -> + withNullablePtr withForeignPtr object $ \object' -> do + sCopy <- librdf_new_node_from_node subject' + pCopy <- librdf_new_node_from_node predicate' + oCopy <- librdf_new_node_from_node object' + initialize + (librdf_new_statement_from_nodes world' sCopy pCopy oCopy) + p_librdf_free_statement + +-- | An abstraction used for getting statement components. +statementGet :: (Ptr RedlandStatement -> IO (Ptr RedlandNode)) + -> ForeignPtr RedlandStatement + -> IO (Maybe (ForeignPtr RedlandNode)) +statementGet f statement = + withForeignPtr statement $ \statement' -> do + oldNode <- f statement' + if oldNode == nullPtr + then pure Nothing + else Just <$> + initialize (librdf_new_node_from_node oldNode) p_librdf_free_node + +-- | An abstraction used for setting statement components. +statementSet :: (Ptr RedlandStatement -> Ptr RedlandNode -> IO ()) + -> ForeignPtr RedlandStatement + -> Maybe (ForeignPtr RedlandNode) + -> IO () +statementSet f statement node = + withForeignPtr statement $ \statement' -> + case node of + Nothing -> f statement' nullPtr + Just node' -> withForeignPtr node' $ \node'' -> do + nodeCopy <- librdf_new_node_from_node node'' + f statement' nodeCopy + +statementGetSubject :: ForeignPtr RedlandStatement + -> IO (Maybe (ForeignPtr RedlandNode)) +statementGetSubject = statementGet librdf_statement_get_subject + +statementSetSubject :: ForeignPtr RedlandStatement + -> Maybe (ForeignPtr RedlandNode) + -> IO () +statementSetSubject = statementSet librdf_statement_set_subject + +statementGetPredicate :: ForeignPtr RedlandStatement + -> IO (Maybe (ForeignPtr RedlandNode)) +statementGetPredicate = statementGet librdf_statement_get_predicate + +statementSetPredicate :: ForeignPtr RedlandStatement + -> Maybe (ForeignPtr RedlandNode) + -> IO () +statementSetPredicate = statementSet librdf_statement_set_predicate + +statementGetObject :: ForeignPtr RedlandStatement + -> IO (Maybe (ForeignPtr RedlandNode)) +statementGetObject = statementGet librdf_statement_get_object + +statementSetObject :: ForeignPtr RedlandStatement + -> Maybe (ForeignPtr RedlandNode) + -> IO () +statementSetObject = statementSet librdf_statement_set_object + -- * Triple stores @@ -468,6 +562,27 @@ redlandStorageWithOptions world sname name opt = p_librdf_free_storage +-- * Stream of triples (librdf_statement) + +streamEnd :: ForeignPtr RedlandStream -> IO Bool +streamEnd stream = + withForeignPtr stream $ fmap (/= 0) . librdf_stream_end + +streamNext :: ForeignPtr RedlandStream + -> IO Bool + -- ^ 'True' if it's not finished. +streamNext stream = + withForeignPtr stream $ fmap (== 0) . librdf_stream_next + +streamGetObject :: ForeignPtr RedlandStream + -> Initializer RedlandStatement +streamGetObject stream = + withForeignPtr stream $ \stream' -> do + statement <- librdf_stream_get_object stream' + initialize (librdf_new_statement_from_statement statement) + p_librdf_free_statement + + -- * URI redlandURI :: ForeignPtr RedlandWorld @@ -487,5 +602,4 @@ uriFromURI uri = uriAsString :: ForeignPtr RedlandURI -> IO String uriAsString uri = - withForeignPtr uri $ \uri' -> - librdf_uri_as_string uri' >>= justSharedCString + withForeignPtr uri $ librdf_uri_as_string >=> justSharedCString diff --git a/Redland/Util.hs b/Redland/Util.hs index 0472dde..3d34206 100644 --- a/Redland/Util.hs +++ b/Redland/Util.hs @@ -11,7 +11,8 @@ Utility functions based on mid-level bindings. module Redland.Util where import Foreign -import Control.Exception +import Control.Monad +import Data.Maybe import Redland.LowLevel import Redland.MidLevel @@ -30,6 +31,19 @@ withHash world factory l f = f hash +-- * RDF Graph (librdf_model) + +withStatements :: ForeignPtr RedlandWorld + -> ForeignPtr RedlandModel + -> Triple + -> ([Triple] -> IO a) + -> IO a +withStatements world model t f = + withNew (tripleToStatement world t) $ \statement -> + withNew (modelFindStatements model statement) $ + streamToList >=> f + + -- * RDF term (librdf_node) data Node = BlankNode String @@ -47,28 +61,29 @@ redlandNodeToNode rn = do (_, True, _) -> LiteralNode <$> nodeGetLiteralValue rn _ -> ResourceNode <$> (nodeGetURI rn >>= uriAsString) +nodeToRedlandNode :: ForeignPtr RedlandWorld + -> Node + -> Initializer RedlandNode +nodeToRedlandNode world (BlankNode s) = nodeFromBlankIdentifier world (Just s) +nodeToRedlandNode world (LiteralNode s) = nodeFromLiteral world s Nothing False +nodeToRedlandNode world (ResourceNode s) = + withNew (redlandURI world s) $ nodeFromURI world + -- * Parsers -- | Tries different parsers until one of them succeeds. -tryParseStringIntoModel :: ForeignPtr RedlandWorld - -> [String] - -- ^ parsers to try - -> ForeignPtr RedlandModel - -> ForeignPtr RedlandURI - -- ^ base URI - -> String - -- ^ string to parse - -> IO () -tryParseStringIntoModel world (parser:parsers) model uri str = - handle tryNext $ - withNew (redlandParser world (Just parser) Nothing Nothing) $ \parser -> - parseStringIntoModel parser str uri model - where - tryNext :: RedlandException -> IO () - tryNext (OperationException _) = tryParseStringIntoModel world parsers model uri str - tryNext e = throw e -tryParseStringIntoModel world [] model uri str = throw ParseFailure +guessingParseStringIntoModel :: ForeignPtr RedlandWorld + -> ForeignPtr RedlandModel + -> ForeignPtr RedlandURI + -- ^ base URI + -> String + -- ^ string to parse + -> IO () +guessingParseStringIntoModel world model uri str = do + parser <- parserGuessName2 world Nothing (Just str) Nothing + withNew (redlandParser world parser Nothing Nothing) $ \p -> + parseStringIntoModel p str uri model -- * Querying @@ -85,8 +100,7 @@ withQuery :: ForeignPtr RedlandWorld -> IO a withQuery world model ql qs bURI f = withNew (redlandQuery world ql Nothing qs bURI) $ \query -> - withNew (modelQueryExecute model query) $ \results -> - queryResultsToList results >>= f + withNew (modelQueryExecute model query) $ queryResultsToList >=> f -- * Query results @@ -112,6 +126,58 @@ queryResultsToList qr = do pure (name, val) +-- * RDF Triple (librdf_statement) + +data Triple = Triple { subject :: Maybe Node + , predicate :: Maybe Node + , object :: Maybe Node + } deriving (Eq, Show) + +statementToTriple :: ForeignPtr RedlandStatement + -> IO Triple +statementToTriple statement = do + s <- componentToTriple statementGetSubject + p <- componentToTriple statementGetPredicate + o <- componentToTriple statementGetObject + pure $ Triple s p o + where + componentToTriple :: (ForeignPtr RedlandStatement -> + IO (Maybe (ForeignPtr RedlandNode))) + -> IO (Maybe Node) + componentToTriple f = do + c <- f statement + case c of + Just c' -> Just <$> redlandNodeToNode c' + Nothing -> pure Nothing + +tripleToStatement :: ForeignPtr RedlandWorld + -> Triple + -> Initializer RedlandStatement +tripleToStatement world (Triple s p o) = do + statement <- redlandStatement world + let maybeSet f mn = case mn of + Just n -> withNew (nodeToRedlandNode world n) $ \n' -> + f statement (Just n') + Nothing -> pure () + maybeSet statementSetSubject s + maybeSet statementSetPredicate p + maybeSet statementSetObject o + pure statement + +-- * Stream of triples (librdf_statement) + +streamToList :: ForeignPtr RedlandStream -> IO [Triple] +streamToList stream = do + done <- streamEnd stream + if done + then pure [] + else do + triple <- streamGetObject stream >>= statementToTriple + next <- streamNext stream + rest <- if next then streamToList stream else pure [] + pure (triple : rest) + + -- * Other -- | Initializes world, storage, model, and base URI at once. -- cgit v1.2.3