From b52e6bf3822150fbca9a6aadd3ce73dcdf7ed0ad Mon Sep 17 00:00:00 2001 From: defanor Date: Wed, 21 Feb 2018 18:36:52 +0300 Subject: Initial commit The bindings are incomplete, but usable at this point. --- Redland/MidLevel.hs | 491 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 491 insertions(+) create mode 100644 Redland/MidLevel.hs (limited to 'Redland/MidLevel.hs') diff --git a/Redland/MidLevel.hs b/Redland/MidLevel.hs new file mode 100644 index 0000000..f8aa546 --- /dev/null +++ b/Redland/MidLevel.hs @@ -0,0 +1,491 @@ +{- | +Module : Redland.MidLevel +Maintainer : defanor +Stability : unstable +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. + +-} + +module Redland.MidLevel where + +import Foreign +import Foreign.C +import Control.Exception + +import Redland.LowLevel + +-- * Exceptions + +data RedlandException = InitializationException + -- ^ Happens when an initializer returns NULL. + -- Gets thrown by 'initialize'. + | OperationException Int + -- ^ Happens on non-zero return value where a + -- zero is expected. Gets thrown by 'perform'. + | StringOperationException + -- ^ Gets thrown by 'justCString' and + -- 'justSharedCString'. + | ParseFailure + deriving Show + +instance Exception RedlandException + + +-- * FFI utility functions + +-- todo: move these into a separate module? + +type Initializer a = IO (ForeignPtr a) + +-- | Initializes a Redland object, throws 'InitializationException' on +-- failure (i.e., if NULL is returned). +initialize :: IO (Ptr a) -> FinalizerPtr a -> Initializer a +initialize i f = do + p <- i + if p == nullPtr + then throw InitializationException + else newForeignPtr f p + +-- | Performs an operation, throws 'OperationException' on failure +-- (i.e., on non-zero return value). +perform :: IO CInt -> IO () +perform a = do + r <- fromIntegral <$> a + if r == 0 + then pure () + else throw (OperationException r) + +-- | 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 + +-- | An abstraction to use with 'withCString' and 'withForeignPtr'. +withNullablePtr :: (a -> (Ptr b -> c) -> c) -> Maybe a -> (Ptr b -> c) -> c +withNullablePtr _ Nothing a = a nullPtr +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 + | cStr == nullPtr = pure Nothing + | otherwise = do + r <- peekCString cStr + free cStr + pure $ pure r + +-- | Like 'maybeCString', but requires a string to be there, and +-- throws 'StringOperationException' if it isn't. +justCString :: CString -> IO String +justCString cStr = do + r <- justSharedCString cStr + free cStr + pure r + +-- | Like 'justCString', but doesn't 'free' the C string. +justSharedCString :: CString -> IO String +justSharedCString cStr + | cStr == nullPtr = throw StringOperationException + | otherwise = peekCString cStr + + +-- * World + +-- not calling librdf_world_open +redlandWorld :: Initializer RedlandWorld +redlandWorld = initialize librdf_new_world p_librdf_free_world + + +-- * Hashes + +redlandHash :: ForeignPtr RedlandWorld + -- ^ world + -> String + -- ^ hash factory name (e.g., "memory") + -> Initializer RedlandHash +redlandHash world name = + withForeignPtr world $ \world' -> + withCString name $ \name' -> + initialize (librdf_new_hash world' name') p_librdf_free_hash + +hashPutStrings :: ForeignPtr RedlandHash + -- ^ hash + -> String + -- ^ key + -> String + -- ^ value + -> IO () +hashPutStrings hash key value = + withForeignPtr hash $ \hash' -> + withCString key $ \key' -> + withCString value $ \value' -> + perform $ librdf_hash_put_strings hash' key' value' + +hashGet :: ForeignPtr RedlandHash + -- ^ hash + -> String + -- ^ key + -> IO (Maybe String) +hashGet hash key = + withForeignPtr hash $ \hash' -> + withCString key $ \key' -> + librdf_hash_get hash' key' >>= maybeCString + +hashGetDel :: ForeignPtr RedlandHash + -- ^ hash + -> String + -- ^ key + -> IO (Maybe String) +hashGetDel hash key = + withForeignPtr hash $ \hash' -> + withCString key $ \key' -> + librdf_hash_get_del hash' key' >>= maybeCString + + +-- * RDF Graph (librdf_model) + +redlandModel :: ForeignPtr RedlandWorld + -- ^ world + -> ForeignPtr RedlandStorage + -- ^ storage + -> String + -- ^ options + -> Initializer RedlandModel + -- ^ model +redlandModel world storage opt = + withForeignPtr world $ \world' -> + withForeignPtr storage $ \storage' -> + withCString opt $ \opt' -> + initialize (librdf_new_model world' storage' opt') p_librdf_free_model + +-- | Acts as a 'RedlandQueryResults' initializer. +modelQueryExecute :: ForeignPtr RedlandModel + -> ForeignPtr RedlandQuery + -> Initializer RedlandQueryResults +modelQueryExecute model query = + withForeignPtr model $ \model' -> + withForeignPtr query $ \query' -> + initialize (librdf_model_query_execute model' query') + p_librdf_free_query_results + +-- | Acts as a 'RedlandStream' initializer. +modelFindStatements :: ForeignPtr RedlandModel + -> ForeignPtr RedlandStatement + -> Initializer RedlandStream +modelFindStatements model statement = + withForeignPtr model $ \model' -> + withForeignPtr statement $ \statement' -> + initialize (librdf_model_find_statements model' statement') + p_librdf_free_stream + +modelSync :: ForeignPtr RedlandModel -> IO () +modelSync model = + withForeignPtr model $ \model' -> + perform $ librdf_model_sync model' + +modelLoad :: ForeignPtr RedlandModel + -> ForeignPtr RedlandURI + -- ^ source URI + -> Maybe String + -- ^ parser name + -> Maybe String + -- ^ MIME type + -> Maybe (ForeignPtr RedlandURI) + -- ^ type URI + -> IO () +modelLoad model source parser mime tURI = + withForeignPtr model $ \model' -> + withForeignPtr source $ \source' -> + withNullablePtr withCString parser $ \parser' -> + withNullablePtr withCString mime $ \mime' -> + withNullablePtr withForeignPtr tURI $ \tURI' -> + perform $ librdf_model_load model' source' parser' mime' tURI' + +-- * RDF term (librdf_node) + +redlandNode :: ForeignPtr RedlandWorld -> Initializer RedlandNode +redlandNode world = + withForeignPtr world $ \world' -> + initialize (librdf_new_node world') p_librdf_free_node + +nodeFromBlankIdentifier :: ForeignPtr RedlandWorld + -> Maybe String + -> Initializer RedlandNode +nodeFromBlankIdentifier world identifier = + withForeignPtr world $ \world' -> + withNullablePtr withCString identifier $ \identifier' -> + initialize (librdf_new_node_from_blank_identifier world' identifier') + p_librdf_free_node + +nodeFromLiteral :: ForeignPtr RedlandWorld + -> String + -> Maybe String + -> Bool + -> Initializer RedlandNode +nodeFromLiteral world val xmlLang isXML = + withForeignPtr world $ \world' -> + withCString val $ \val' -> + withNullablePtr withCString xmlLang $ \xmlLang' -> + let isXML' = if isXML then 1 else 0 in + initialize (librdf_new_node_from_literal world' val' xmlLang' isXML') + p_librdf_free_node + +nodeFromTypedLiteral :: ForeignPtr RedlandWorld + -> String + -> Maybe String + -> Maybe (ForeignPtr RedlandURI) + -> Initializer RedlandNode +nodeFromTypedLiteral world val xmlLang litType = + withForeignPtr world $ \world' -> + withCString val $ \val' -> + withNullablePtr withCString xmlLang $ \xmlLang' -> + withNullablePtr withForeignPtr litType $ \litType' -> + initialize (librdf_new_node_from_typed_literal world' val' xmlLang' litType') + p_librdf_free_node + +nodeFromURI :: ForeignPtr RedlandWorld + -> ForeignPtr RedlandURI + -> Initializer RedlandNode +nodeFromURI world uri = + withForeignPtr world $ \world' -> + withForeignPtr uri $ \uri' -> + initialize (librdf_new_node_from_uri world' uri') + p_librdf_free_node + +nodeFromURIString :: ForeignPtr RedlandWorld + -> String + -> Initializer RedlandNode +nodeFromURIString world uriStr = + withForeignPtr world $ \world' -> + withCString uriStr $ \uriStr' -> + initialize (librdf_new_node_from_uri_string world' uriStr') + p_librdf_free_node + +nodeGetBlankIdentifier :: ForeignPtr RedlandNode -> IO String +nodeGetBlankIdentifier node = + withForeignPtr node $ \node' -> + librdf_node_get_blank_identifier node' >>= justSharedCString + +nodeGetLiteralValue :: ForeignPtr RedlandNode -> IO String +nodeGetLiteralValue node = + withForeignPtr node $ \node' -> + librdf_node_get_literal_value node' >>= justSharedCString + +nodeGetURI :: ForeignPtr RedlandNode -> Initializer RedlandURI +nodeGetURI node = + withForeignPtr node $ \node' -> do + oldURI <- librdf_node_get_uri node' + initialize (librdf_new_uri_from_uri oldURI) p_librdf_free_uri + +nodeIsBlank :: ForeignPtr RedlandNode -> IO Bool +nodeIsBlank node = + withForeignPtr node $ fmap (/= 0) . librdf_node_is_blank + +nodeIsLiteral :: ForeignPtr RedlandNode -> IO Bool +nodeIsLiteral node = + withForeignPtr node $ fmap (/= 0) . librdf_node_is_literal + +nodeIsResource :: ForeignPtr RedlandNode -> IO Bool +nodeIsResource node = + withForeignPtr node $ fmap (/= 0) . librdf_node_is_resource + +nodeToString :: ForeignPtr RedlandNode -> IO String +nodeToString node = + withForeignPtr node $ \node' -> + librdf_node_to_string node' >>= justCString + + +-- * Parsers + +redlandParser :: ForeignPtr RedlandWorld + -- ^ world + -> Maybe String + -- ^ parser name (e.g., "rdfxml", "turtle") + -> Maybe String + -- ^ MIME type + -> Maybe (ForeignPtr RedlandURI) + -- ^ type URI + -> Initializer RedlandParser +redlandParser world name mimeType uri = + withForeignPtr world $ \world' -> + withNullablePtr withCString name $ \name' -> + withNullablePtr withCString mimeType $ \mimeType' -> + withNullablePtr withForeignPtr uri $ \uri' -> + initialize (librdf_new_parser world' name' mimeType' uri') + p_librdf_free_parser + +parseStringIntoModel :: ForeignPtr RedlandParser + -- ^ parser + -> String + -- ^ string to parse + -> ForeignPtr RedlandURI + -- ^ base URI + -> ForeignPtr RedlandModel + -- ^ model + -> IO () +parseStringIntoModel parser str uri model = + withForeignPtr parser $ \parser' -> + withCString str $ \str' -> + withForeignPtr uri $ \uri' -> + withForeignPtr model $ \model' -> + perform $ librdf_parser_parse_string_into_model parser' str' uri' model' + + +-- * Querying + +redlandQuery :: ForeignPtr RedlandWorld + -> String + -- ^ language name + -> Maybe (ForeignPtr RedlandURI) + -- ^ language URI + -> String + -- ^ query string + -> Maybe (ForeignPtr RedlandURI) + -- ^ base URI + -> Initializer RedlandQuery +redlandQuery world lang langURI query baseURI = + withForeignPtr world $ \world' -> + withCString lang $ \lang' -> + withNullablePtr withForeignPtr langURI $ \langURI' -> + withCString query $ \query' -> + withNullablePtr withForeignPtr baseURI $ \baseURI' -> + initialize (librdf_new_query world' lang' langURI' query' baseURI') + p_librdf_free_query + + +-- * Query results + +queryResultsGetCount :: ForeignPtr RedlandQueryResults -> IO Int +queryResultsGetCount results = + withForeignPtr results $ \results' -> + fromIntegral <$> librdf_query_results_get_count results' + +queryResultsNext :: ForeignPtr RedlandQueryResults -> IO Bool +queryResultsNext results = + withForeignPtr results $ \results' -> + (== 0) <$> librdf_query_results_next results' + +queryResultsFinished :: ForeignPtr RedlandQueryResults -> IO Bool +queryResultsFinished results = + withForeignPtr results $ \results' -> + (/= 0) <$> librdf_query_results_finished results' + +-- | Acts as a 'RedlandNode' initializer. +queryResultsGetBindingValue :: ForeignPtr RedlandQueryResults + -> Int + -> Initializer RedlandNode +queryResultsGetBindingValue results offset = + withForeignPtr results $ \results' -> + initialize + (librdf_query_results_get_binding_value results' (fromIntegral offset)) + p_librdf_free_node + +queryResultsGetBindingName :: ForeignPtr RedlandQueryResults + -> Int + -> IO String +queryResultsGetBindingName results offset = + withForeignPtr results $ \results' -> + librdf_query_results_get_binding_name results' (fromIntegral offset) + >>= justSharedCString + +-- | Acts as a 'RedlandNode' initializer. +queryResultsGetBindingValueByName :: ForeignPtr RedlandQueryResults + -> String + -> Initializer RedlandNode +queryResultsGetBindingValueByName results name = + withForeignPtr results $ \results' -> + withCString name $ \name' -> + initialize + (librdf_query_results_get_binding_value_by_name results' name') + p_librdf_free_node + +queryResultsGetBindingsCount :: ForeignPtr RedlandQueryResults + -> IO Int +queryResultsGetBindingsCount results = + withForeignPtr results $ \results' -> + fromIntegral <$> librdf_query_results_get_bindings_count results' + +-- | Acts as a 'RedlandQueryResults' initializer. +queryExecute :: ForeignPtr RedlandQuery + -> ForeignPtr RedlandModel + -> Initializer RedlandQueryResults +queryExecute query model = + withForeignPtr query $ \query' -> + withForeignPtr model $ \model' -> + initialize (librdf_query_execute query' model') p_librdf_free_query_results + + +-- * RDF Triple (librdf_statement) + +redlandStatement :: ForeignPtr RedlandWorld -> Initializer RedlandStatement +redlandStatement world = + withForeignPtr world $ \world' -> + initialize (librdf_new_statement world') p_librdf_free_statement + + +-- * Triple stores + +redlandStorage :: ForeignPtr RedlandWorld + -- ^ world + -> String + -- ^ storage type name ("hashes", "memory", "file", + -- etc) + -> String + -- ^ storage identifier + -> String + -- ^ options + -> Initializer RedlandStorage +redlandStorage world sname name opt = + withForeignPtr world $ \world' -> + withCString sname $ \sname' -> + withCString name $ \name' -> + withCString opt $ \opt' -> + initialize (librdf_new_storage world' sname' name' opt') + p_librdf_free_storage + +redlandStorageWithOptions :: ForeignPtr RedlandWorld + -- ^ world + -> String + -- ^ storage type name ("hashes", "memory", + -- "file", etc) + -> String + -- ^ storage identifier + -> ForeignPtr RedlandHash + -- ^ options + -> Initializer RedlandStorage +redlandStorageWithOptions world sname name opt = + withForeignPtr world $ \world' -> + withCString sname $ \sname' -> + withCString name $ \name' -> + withForeignPtr opt $ \opt' -> + initialize (librdf_new_storage_with_options world' sname' name' opt') + p_librdf_free_storage + + +-- * URI + +redlandURI :: ForeignPtr RedlandWorld + -- ^ world + -> String + -- ^ URI string + -> Initializer RedlandURI +redlandURI world uriStr = + withForeignPtr world $ \world' -> + withCString uriStr $ \uriStr' -> + initialize (librdf_new_uri world' uriStr') p_librdf_free_uri + +uriFromURI :: ForeignPtr RedlandURI -> Initializer RedlandURI +uriFromURI uri = + withForeignPtr uri $ \uri' -> + initialize (librdf_new_uri_from_uri uri') p_librdf_free_uri + +uriAsString :: ForeignPtr RedlandURI -> IO String +uriAsString uri = + withForeignPtr uri $ \uri' -> + librdf_uri_as_string uri' >>= justSharedCString -- cgit v1.2.3