-- 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 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 -- , 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 . 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 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