summaryrefslogtreecommitdiff
path: root/Redland/Util.hs
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2018-02-21 18:36:52 +0300
committerdefanor <defanor@uberspace.net>2018-02-21 18:36:52 +0300
commitb52e6bf3822150fbca9a6aadd3ce73dcdf7ed0ad (patch)
tree5a095150a93cb21957984004c975232d0bf1e1cd /Redland/Util.hs
Initial commit
The bindings are incomplete, but usable at this point.
Diffstat (limited to 'Redland/Util.hs')
-rw-r--r--Redland/Util.hs140
1 files changed, 140 insertions, 0 deletions
diff --git a/Redland/Util.hs b/Redland/Util.hs
new file mode 100644
index 0000000..0472dde
--- /dev/null
+++ b/Redland/Util.hs
@@ -0,0 +1,140 @@
+{- |
+Module : Redland.Util
+Maintainer : defanor <defanor@uberspace.net>
+Stability : unstable
+Portability : non-portable (GHC extensions are used)
+
+Utility functions based on mid-level bindings.
+
+-}
+
+module Redland.Util where
+
+import Foreign
+import Control.Exception
+
+import Redland.LowLevel
+import Redland.MidLevel
+
+
+-- * Hashes
+
+withHash :: ForeignPtr RedlandWorld
+ -> String
+ -> [(String, String)]
+ -> (ForeignPtr RedlandHash -> IO a)
+ -> IO a
+withHash world factory l f =
+ withNew (redlandHash world factory) $ \hash -> do
+ mapM_ (uncurry (hashPutStrings hash)) l
+ f hash
+
+
+-- * RDF term (librdf_node)
+
+data Node = BlankNode String
+ | LiteralNode String
+ | ResourceNode String
+ deriving (Eq, Show)
+
+redlandNodeToNode :: ForeignPtr RedlandNode -> IO Node
+redlandNodeToNode rn = do
+ isBlank <- nodeIsBlank rn
+ isLiteral <- nodeIsLiteral rn
+ isResource <- nodeIsResource rn
+ case (isBlank, isLiteral, isResource) of
+ (True, _, _) -> BlankNode <$> nodeGetBlankIdentifier rn
+ (_, True, _) -> LiteralNode <$> nodeGetLiteralValue rn
+ _ -> ResourceNode <$> (nodeGetURI rn >>= uriAsString)
+
+
+-- * 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
+
+
+-- * Querying
+
+withQuery :: ForeignPtr RedlandWorld
+ -> ForeignPtr RedlandModel
+ -> String
+ -- ^ query language
+ -> String
+ -- ^ query string
+ -> Maybe (ForeignPtr RedlandURI)
+ -- ^ base URI
+ -> (QueryResults -> IO a)
+ -> 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
+
+
+-- * Query results
+
+type QueryResults = [[(String, Node)]]
+
+queryResultsToList :: ForeignPtr RedlandQueryResults -> IO QueryResults
+queryResultsToList qr = do
+ done <- queryResultsFinished qr
+ if done
+ then pure []
+ else do
+ bindingCnt <- queryResultsGetBindingsCount qr
+ bindings <- mapM readBinding [0..bindingCnt - 1]
+ next <- queryResultsNext qr
+ rest <- if next then queryResultsToList qr else pure []
+ pure (bindings : rest)
+ where
+ readBinding :: Int -> IO (String, Node)
+ readBinding n = do
+ name <- queryResultsGetBindingName qr n
+ val <- queryResultsGetBindingValue qr n >>= redlandNodeToNode
+ pure (name, val)
+
+
+-- * Other
+
+-- | Initializes world, storage, model, and base URI at once.
+withWSMU :: String
+ -- ^ storage factory
+ -> [(String, String)]
+ -- ^ storage options
+ -> String
+ -- ^ storage identifier
+ -> String
+ -- ^ model options
+ -> String
+ -- ^ base URI
+ -> (ForeignPtr RedlandWorld ->
+ ForeignPtr RedlandStorage ->
+ ForeignPtr RedlandModel ->
+ ForeignPtr RedlandURI ->
+ IO a)
+ -> IO a
+withWSMU sFactory sOpt sIdent mOpt bURI f =
+ withNew redlandWorld $ \world ->
+ withHash world "memory" sOpt $ \sOpt' ->
+ withNew (redlandStorageWithOptions world sFactory sIdent sOpt') $ \storage ->
+ withNew (redlandModel world storage mOpt) $ \model ->
+ withNew (redlandURI world bURI) $ \uri ->
+ f world storage model uri