1 files changed, 491 insertions, 0 deletions
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 <defanor@uberspace.net>
+Stability   :  unstable
+Portability :  non-portable (GHC extensions are used)
+
+Mid-level <http://librdf.org/docs/api/index.html Redland RDF library>
+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