tracker-0.1: System/Tracker.chs
-- Tracker.chs: client library for Tracker metadata search tool
-- Copyright (C) 2008 Will Thompson
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
module System.Tracker
( -- * Types and enums
ServiceType (..)
, TrackerClient
, Field
, Keyword
, Status
, MetadataClass
-- * Connecting to the Tracker daemon
, withTrackerErr
, withTracker
, withTrackerWarnings
-- * Probing the daemon
, getVersion
, getStatus
, getStats
-- * Metadata
, getRegisteredMetadataClasses
-- * Searching
, searchGetHitCount
, searchText
, searchTextDetailed
, searchGetSnippet
, searchMetadata
, searchQuery
, searchSuggest
)
where
#include <tracker.h>
import Foreign
import Foreign.C
import System.Glib.GError
import Control.Applicative ((<$>))
import Control.Monad (liftM, forM)
import Control.Exception (bracket)
import Data.Map (Map)
import qualified Data.Map as M
{#context lib="tracker" prefix="tracker" #}
{#enum ServiceType { underscoreToCase
, SERVICE_TEXT_FILES as Text
, SERVICE_DEVELOPMENT_FILES as Development
, SERVICE_OTHER_FILES as Other
, SERVICE_VFS_FILES as VFS
, SERVICE_VFS_FOLDERS as VFSFolders
, SERVICE_VFS_DOCUMENTS as VFSDocuments
, SERVICE_VFS_IMAGES as VFSImages
, SERVICE_VFS_MUSIC as VFSMusic
, SERVICE_VFS_VIDEOS as VFSVideos
, SERVICE_VFS_TEXT_FILES as VFSText
, SERVICE_VFS_DEVELOPMENT_FILES as VFSDevelopment
, SERVICE_VFS_OTHER_FILES as VFSOther
, SERVICE_EMAILATTACHMENTS as EmailAttachments
}
with prefix="Service" deriving (Eq, Show, Read)#}
-- |Possible statuses of the Tracker daemon, as returned by 'getStatus'.
data Status = Initializing | Watching | Indexing | Pending | Optimizing | Idle
| Shutdown
deriving (Read, Show)
{#pointer *TrackerClient as TrackerClient newtype #}
{#pointer *GPtrArray as GPtrArray newtype #}
type Field = String
type Keyword = String
data MetadataTypeDetails = MetadataTypeDetails { metadataType :: String
, isEmbedded :: Bool
, isWriteable :: Bool
}
deriving Show
instance Storable MetadataTypeDetails where
sizeOf _ = {# sizeof MetaDataTypeDetails #}
alignment _ = alignment (undefined :: CString)
peek mtdPtr = do
-- argh. the first field of MetaDataTypeDetails is called 'type'.
-- c2hs doesn't like that much. Let's just assume the offset is 0.
ty <- peekByteOff mtdPtr 0 >>= peekCString
emb <- {# get MetaDataTypeDetails->is_embedded #} mtdPtr >>= boolinate
wri <- {# get MetaDataTypeDetails->is_writeable #} mtdPtr >>= boolinate
return $ MetadataTypeDetails ty emb wri
where boolinate x = return (x /= 0)
poke mtdPtr (MetadataTypeDetails ty emb wri) = do
-- ditto above
newCString ty >>= pokeByteOff mtdPtr 0
{# set MetaDataTypeDetails->is_embedded #} mtdPtr (if emb then 1 else 0)
{# set MetaDataTypeDetails->is_writeable #} mtdPtr (if wri then 1 else 0)
-- these next two are probably meant to be isomophic?
{#enum MetadataTypes as MetadataTypes {underscoreToCase}
with prefix="Data" deriving (Eq)#}
type MetadataType = String
-- |These are meant to be the names specified in
-- <http://freedesktop.org/wiki/Specifications/shared-filemetadata-spec>, but
-- have colons rather than periods in the names.
type MetadataClass = String
-- |Like 'withTracker', but wraps any 'GError' exception's message with 'error'
withTrackerErr :: (TrackerClient -> IO a) -> IO a
withTrackerErr = handleGError errorMessage . withTracker
where errorMessage (GError _ _ msg) = error $ "tracker error: " ++ msg
-- |Runs the given Tracker action with warnings disabled.
withTracker :: (TrackerClient -> IO a) -> IO a
withTracker = withTrackerWarnings False
-- |Runs the given Tracker action.
withTrackerWarnings :: Bool -- ^ whether to enable warnings
-> (TrackerClient -> IO a)
-> IO a
withTrackerWarnings enable_warnings action =
bracket connect disconnect action
where connect = {# call tracker_connect #} $ fromIntegral (fromEnum enable_warnings)
disconnect = {# call tracker_disconnect #}
-- |Gets the (major, minor, micro)-version number of the Tracker daemon.
getVersion :: TrackerClient -> IO (Int, Int, Int)
getVersion client = do
-- XXYYZZ -> (XX,YY,ZZ)
ret <- fromIntegral <$> propagateGError ({# call tracker_get_version #} client)
let (major, rest) = ret `divMod` 10000
let (minor, micro) = rest `divMod` 100
return (major, minor, micro)
-- |Gets the current status of the Tracker daemon.
getStatus :: TrackerClient -> IO Status
getStatus c = do
status <- propagateGError $ {# call tracker_get_status #} c
read <$> swallowCString status
-- |Get statistics for services that have been indexed. Returns a map from
-- service name to number of indexed items.
getStats :: TrackerClient -> IO (Map String Int)
getStats client = do
ptrArray <- propagateGError $ \gErr -> {# call tracker_get_stats #} client gErr
(M.fromList . map tuplize) <$> swallowArrayOfStrings ptrArray
where tuplize [a,b] = (a, read b)
-- This would probably work if getRegisteredMetadataTypes returned useful strings.
getMetadataTypeDetails :: MetadataType
-> TrackerClient
-> IO MetadataTypeDetails
getMetadataTypeDetails metaType client = do
mtdPtr <- propagateGError $ \gerrorPtr ->
withCString metaType $ \metaType' ->
{# call tracker_metadata_get_type_details #} client metaType' gerrorPtr
peek $ castPtr mtdPtr
-- This doesn't work. tracker_metadata_get_registered_types () returns useless junk.
-- See <http://bugzilla.gnome.org/show_bug.cgi?id=513643>.
getRegisteredMetadataTypes :: TrackerClient -> String -> IO [MetadataType]
getRegisteredMetadataTypes client metaType = do
types <- propagateGError $ \gerrorPtr ->
withCString metaType $ \mt ->
{# call tracker_metadata_get_registered_types #} client mt gerrorPtr
swallowCStringArray types
-- |Returns all metadata type classes registered with the Tracker daemon.
getRegisteredMetadataClasses :: TrackerClient -> IO [MetadataClass]
getRegisteredMetadataClasses client = do
classes <- propagateGError $ \gerrorPtr ->
{# call tracker_metadata_get_registered_classes #} client gerrorPtr
swallowCStringArray classes
-- |Fetches the number of objects of a given type that would match the given
-- query if you ran 'searchText'.
searchGetHitCount :: ServiceType -- ^ type of object to search
-> String -- ^ search text
-> TrackerClient
-> IO Int -- ^ number of matching objects of given type
searchGetHitCount ty query client = liftM fromIntegral $
propagateGError $ \gerrorPtr ->
withCString query $ \queryStr ->
{# call tracker_search_get_hit_count #} client ty' queryStr gerrorPtr
where ty' = fromIntegral $ fromEnum ty
-- |Runs a simple text query (conjunction of words) for a particular type of
-- object, and returns (a sublist of) the matching paths.
searchText :: ServiceType -- ^ type of object to search
-> String -- ^ search text
-> Int -- ^ offset from start of list of hits
-> Int -- ^ maximum number of hits to return
-> TrackerClient
-> IO [FilePath] -- ^ URIs of objects found
searchText ty query offset max_hits client = do
uris <- propagateGError $ \gerrorPtr ->
withCString query $ \queryStr -> do
{# call tracker_search_text #} client live_query_id ty' queryStr
offset' max_hits' gerrorPtr
swallowCStringArray uris
where offset' = fromIntegral offset :: CInt
max_hits' = fromIntegral max_hits :: CInt
ty' = fromIntegral $ fromEnum ty
live_query_id = -1
-- |Like 'searchText', but returns the service type and mime type of each
-- result, along with its URI.
searchTextDetailed :: ServiceType -- ^ type of object to search
-> String -- ^ search text
-> Int -- ^ offset from start of list of hits
-> Int -- ^ maximum number of hits to return
-> TrackerClient
-> IO [(FilePath, ServiceType, String)] -- ^ (URI, service type, MIME type)
searchTextDetailed ty query offset max_hits client = do
things <- propagateGError $ \gerrorPtr ->
withCString query $ \queryStr -> do
{# call tracker_search_text_detailed #} client live_query_id ty'
queryStr offset' max_hits' gerrorPtr
cStringArrays <- swallowGPtrArray things
lists <- mapM swallowCStringArray cStringArrays
return $ map tuplize lists
where offset' = fromIntegral offset :: CInt
max_hits' = fromIntegral max_hits :: CInt
ty' = fromIntegral $ fromEnum ty
live_query_id = -1
tuplize [path, service, mime] = (path, read service, mime)
-- |Searches a given file for a string, and returns a snippet of text with the
-- match enclosed in <b> tags.
searchGetSnippet :: ServiceType
-> FilePath -- ^ The file to search
-> String -- ^ search text
-> TrackerClient
-> IO String -- ^ Snippet of HTML with emboldened match.
searchGetSnippet ty uri text client = do
snippet <- propagateGError $ \gerrorPtr ->
withCString uri $ \uri' ->
withCString text $ \text' ->
{# call tracker_search_get_snippet #} client ty' uri' text' gerrorPtr
swallowCString snippet
where ty' = fromIntegral $ fromEnum ty
-- |Searches a specific metadata field for a search term.
searchMetadata :: ServiceType -- ^ type of object to search
-> Field -- ^ name of metadata field to search
-> String -- ^ search text
-> Int -- ^ offset from start of list of hits
-> Int -- ^ maximum number of hits to return
-> TrackerClient
-> IO [FilePath] -- ^ matching URIs
searchMetadata ty field query offset max_hits client = do
uris <- propagateGError $ \gerrorPtr ->
withCString field $ \fieldStr ->
withCString query $ \queryStr -> do
{# call tracker_search_metadata #} client ty' fieldStr queryStr
offset' max_hits' gerrorPtr
swallowCStringArray uris
where offset' = fromIntegral offset :: CInt
max_hits' = fromIntegral max_hits :: CInt
ty' = fromIntegral $ fromEnum ty
-- |Searches specified service for matching entities, based on all of the three
-- optional conditions supplied.
searchQuery :: ServiceType
-> [Field] -- ^ metadata fields to return in addition to the URI and service
-> Maybe String -- ^ text to search for in a full text search of all indexed fields
-> Maybe Keyword -- ^ filter results on a keyword
-> Maybe String -- ^ an RDF query condition
-> Int -- ^ offset from start of list of hits
-> Int -- ^ maximum number of hits to return
-> Bool -- ^ whether to sort results by their service
-> TrackerClient
-> IO [(FilePath, ServiceType, [String])] -- ^ URI, service type, and values of requested fields.
searchQuery ty fields search_text keyword rdfQuery offset max_hits sort_results client = do
ptrArr <- propagateGError $ \gerrorPtr ->
withCStringArray0 fields $ \fieldsArr ->
maybeWithCString search_text $ \search_textStr ->
maybeWithCString keyword $ \keywordStr ->
maybeWithCString rdfQuery $ \rdfQueryStr ->
{# call tracker_search_query #} client live_query_id ty'
fieldsArr search_textStr keywordStr rdfQueryStr offset'
max_hits' sort' gerrorPtr
map tuplize <$> swallowArrayOfStrings ptrArr
where offset' = fromIntegral offset :: CInt
max_hits' = fromIntegral max_hits :: CInt
ty' = fromIntegral $ fromEnum ty
sort' = if sort_results then 1 else 0
live_query_id = -1
tuplize (path:ty:fs) = (path, read ty, fs)
-- |Suggests a spelling correction based on the word index.
searchSuggest :: String -- ^ search text
-> Int -- ^ maximum (edit?) distance
-> TrackerClient
-> IO String -- ^ suggested spelling
searchSuggest text dist client = do
suggestion <- propagateGError $ \gerrorPtr ->
withCString text $ \text' ->
{# call tracker_search_suggest #} client text' dist' gerrorPtr
swallowCString suggestion
where dist' = fromIntegral dist
--
-- Unexported utility functions
--
swallowCString :: CString -> IO String
swallowCString ptr = do
s <- peekCString ptr
free ptr
return s
swallowCStringArray :: Ptr CString -> IO [String]
swallowCStringArray arr = do
stringPtrs <- peekArray0 nullPtr arr
free arr
mapM swallowCString stringPtrs
swallowGPtrArray :: GPtrArray -> IO [Ptr a]
swallowGPtrArray gpa@(GPtrArray ptr) = do
len <- fromIntegral <$> {# get GPtrArray->len #} ptr
start <- {# get GPtrArray->pdata #} ptr
ptrs <- forM [0..len-1] $ \off -> castPtr <$> start `peekElemOff` off
{# call g_ptr_array_free #} gpa 0
return ptrs
swallowArrayOfStrings :: GPtrArray -> IO [[String]]
swallowArrayOfStrings gpa = swallowGPtrArray gpa >>= mapM swallowCStringArray
maybeWithCString :: Maybe String -> (CString -> IO a) -> IO a
maybeWithCString = maybe ($ nullPtr) withCString
withCStringArray0 :: [String] -> (Ptr CString -> IO a) -> IO a
withCStringArray0 strings act = do
cStrings <- mapM newCString strings
res <- withArray0 nullPtr cStrings act
mapM_ free cStrings
return res