notmuch-haskell 0.2.2 → 1.0.0.3

raw patch · 4 files changed

+204/−111 lines, 4 filesdep −haskell98dep ~basedep ~containersdep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies removed: haskell98

Dependency ranges changed: base, containers, filepath, old-locale, parseargs, time

API changes (from Hackage documentation)

Files

• Foreign/NOTMUCH_H.hsc +28/−6
• Foreign/Notmuch.hs +141/−86
• NotmuchTest.hs +17/−14
• notmuch-haskell.cabal +18/−5

@@ -9,6 +9,11 @@ --   gcc -E -dD notmuch.h | hsffig >NOTMUCH_H.hsc -- Later hand-edited +-- XXX As of GHC 7.2, the #include directives are simply+-- ignored, even with -fvia-C. This is pretty painful, as it+-- means that changes to APIs are not noticed by the+-- compiler. Uggh.+ #if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409 #include <Rts.h> #endif@@ -22,7 +27,7 @@  #def void _dummy_force_NOTMUCH_H_hsc_c (void) { } -{-# OPTIONS -fglasgow-exts -XForeignFunctionInterface #-}+{-# OPTIONS -XForeignFunctionInterface #-}  #include "notmuch.h" @@ -33,7 +38,6 @@   module Foreign.C.Types) where  import Foreign-import Foreign.Ptr import Foreign.C.Types import Foreign.C.String @@ -51,14 +55,20 @@   f_notmuch_status_to_string :: CInt -> IO (Ptr (CChar))  foreign import ccall "static notmuch.h notmuch_database_create"-  f_notmuch_database_create :: Ptr (CChar) -> IO (Ptr (S__notmuch_database))+  f_notmuch_database_create :: Ptr (CChar) -> Ptr (Ptr (S__notmuch_database)) -> IO (CInt)  foreign import ccall "static notmuch.h notmuch_database_open"-  f_notmuch_database_open :: Ptr (CChar) -> CInt -> IO (Ptr (S__notmuch_database))+  f_notmuch_database_open :: Ptr (CChar) -> CInt -> Ptr (Ptr (S__notmuch_database)) -> IO (CInt)  foreign import ccall "static notmuch.h notmuch_database_close"   f_notmuch_database_close :: Ptr (S__notmuch_database) -> IO (()) +foreign import ccall "static notmuch.h notmuch_database_destroy"+  f_notmuch_database_destroy :: Ptr (S__notmuch_database) -> IO (())++foreign import ccall "static notmuch.h &notmuch_database_destroy"+  pf_notmuch_database_destroy :: FunPtr (Ptr (S__notmuch_database) -> IO (()))+ foreign import ccall "static notmuch.h notmuch_database_get_path"   f_notmuch_database_get_path :: Ptr (S__notmuch_database) -> IO (Ptr (CChar)) @@ -73,8 +83,14 @@ foreign import ccall "wrapper"   w_notmuch_database_upgrade_1 :: (Ptr (CChar) -> CDouble -> IO (())) -> IO (FunPtr (Ptr (CChar) -> CDouble -> IO (()))) +foreign import ccall "static notmuch.h notmuch_database_begin_atomic"+  f_notmuch_database_begin_atomic :: Ptr (S__notmuch_database) -> IO (CInt)++foreign import ccall "static notmuch.h notmuch_database_end_atomic"+  f_notmuch_database_end_atomic :: Ptr (S__notmuch_database) -> IO (CInt)+ foreign import ccall "static notmuch.h notmuch_database_get_directory"-  f_notmuch_database_get_directory :: Ptr (S__notmuch_database) -> Ptr (CChar) -> IO (Ptr (S__notmuch_directory))+  f_notmuch_database_get_directory :: Ptr (S__notmuch_database) -> Ptr (CChar) -> Ptr (Ptr (S__notmuch_directory)) -> IO (CInt)  foreign import ccall "static notmuch.h notmuch_database_add_message"   f_notmuch_database_add_message :: Ptr (S__notmuch_database) -> Ptr (CChar) -> Ptr (Ptr (S__notmuch_message)) -> IO (CInt)@@ -83,7 +99,7 @@   f_notmuch_database_remove_message :: Ptr (S__notmuch_database) -> Ptr (CChar) -> IO (CInt)  foreign import ccall "static notmuch.h notmuch_database_find_message"-  f_notmuch_database_find_message :: Ptr (S__notmuch_database) -> Ptr (CChar) -> IO (Ptr (S__notmuch_message))+  f_notmuch_database_find_message :: Ptr (S__notmuch_database) -> Ptr (CChar) -> Ptr (Ptr (S__notmuch_message)) -> IO (CInt)  foreign import ccall "static notmuch.h notmuch_database_get_all_tags"   f_notmuch_database_get_all_tags :: Ptr (S__notmuch_database) -> IO (Ptr (S__notmuch_tags))@@ -91,6 +107,9 @@ foreign import ccall "static notmuch.h notmuch_query_create"   f_notmuch_query_create :: Ptr (S__notmuch_database) -> Ptr (CChar) -> IO (Ptr (S__notmuch_query)) +foreign import ccall "static notmuch.h notmuch_query_set_omit_excluded"+  f_notmuch_query_set_omit_excluded :: Ptr (S__notmuch_query) -> CInt -> IO (())+ foreign import ccall "static notmuch.h notmuch_query_set_sort"   f_notmuch_query_set_sort :: Ptr (S__notmuch_query) -> CInt -> IO (()) @@ -108,6 +127,9 @@  foreign import ccall "static notmuch.h notmuch_threads_valid"   f_notmuch_threads_valid :: Ptr (S__notmuch_threads) -> IO (CInt)++foreign import ccall "static notmuch.h notmuch_query_count_threads"+  f_notmuch_query_count_threads :: Ptr (S__notmuch_query) -> IO (CUInt)  foreign import ccall "static notmuch.h notmuch_threads_get"   f_notmuch_threads_get :: Ptr (S__notmuch_threads) -> IO (Ptr (S__notmuch_thread))

@@ -4,22 +4,24 @@ -- Licensed LGPL v3: please see the file COPYING in this -- source distribution for licensing information. --- | This is a very preliminary higher-level Haskell binding+-- | This is a half-assed higher-level Haskell binding -- for the Notmuch (notmuchmail.org) email indexing library. -- There is no documentation here; see the Notmuch -- documentation for hints on how to use this.  module Foreign.Notmuch (   Database, databaseCreate, DatabaseMode(..),-  databaseOpen, databaseClose, databaseGetPath,+  databaseOpen, databaseClose, databaseDestroy, databaseGetPath,   databaseGetVersion, databaseNeedsUpgrade,   UpgradeCallback, databaseUpgrade,+  databaseBeginAtomic, databaseEndAtomic,   Directory, databaseGetDirectory,   Message, Messages, databaseAddMessage,   databaseRemoveMessage, databaseFindMessage,   Tags, databaseGetAllTags,-  Query, queryCreate, SortOrder(..), querySetSortOrder,-  Thread, Threads, queryThreads,+  Query, queryCreate, querySetOmitExcluded, +  SortOrder(..), querySetSortOrder,+  Thread, Threads, queryCountThreads, queryThreads,   queryMessages, queryCountMessages,   getThreadID, threadCountMessages, threadCountMatchedMessages,   threadGetToplevelMessages, threadGetAuthors,@@ -42,16 +44,19 @@ import Data.List import Data.Time import Data.Time.Clock.POSIX-import System.FilePath -newtype Database = Database (Ptr S__notmuch_database)+newtype Database = Database (ForeignPtr S__notmuch_database)  databaseCreate :: FilePath -> IO Database-databaseCreate name = do-  db <- withCString name f_notmuch_database_create-  when (db == nullPtr) $-       fail "database create failed"-  return $ Database db+databaseCreate filename = alloca dbFun where+  dbFun dbPtr = do+    let create fn =+          f_notmuch_database_create fn dbPtr+    s <- withCString filename create+    statusCheck s+    cdb <- peek dbPtr+    db <- newForeignPtr pf_notmuch_database_destroy cdb+    return $ Database db  -- XXX Deriving Enum will only work if these fields are in -- the same order as in notmuch.h and there are no gaps@@ -62,25 +67,34 @@     deriving Enum  databaseOpen :: FilePath -> DatabaseMode -> IO Database-databaseOpen name databaseMode = do-  db <- withCString name $-        flip f_notmuch_database_open $-        fromIntegral $ fromEnum databaseMode-  when (db == nullPtr) $-       fail "database open failed"-  return $ Database db+databaseOpen filename databaseMode = alloca dbFun where+  dbFun dbPtr = do+    let open mode fn =+          f_notmuch_database_open fn mode dbPtr+    s <- withCString filename (open (fromIntegral (fromEnum databaseMode)))+    statusCheck s+    cdb <- peek dbPtr+    db <- newForeignPtr pf_notmuch_database_destroy cdb+    return $ Database db +withDatabase :: Database -> ((Ptr S__notmuch_database) -> IO a) -> IO a+withDatabase (Database db) f = withForeignPtr db f+ databaseClose :: Database -> IO ()-databaseClose (Database db) = f_notmuch_database_close db+databaseClose db = withDatabase db f_notmuch_database_close +databaseDestroy :: Database -> IO ()+databaseDestroy db = withDatabase db f_notmuch_database_destroy+ databaseGetPath :: Database -> IO FilePath-databaseGetPath (Database db) =-    resultString $ f_notmuch_database_get_path db+databaseGetPath db = withDatabase db $+    resultString . f_notmuch_database_get_path  databaseGetVersion :: Database -> IO Int-databaseGetVersion (Database db) = do-  v <- f_notmuch_database_get_version db-  return $ fromIntegral v+databaseGetVersion db = +  withDatabase db $ \dbp -> do+    v <- f_notmuch_database_get_version dbp+    return $ fromIntegral v  resultBool :: IO CInt -> IO Bool resultBool = fmap (/= 0)@@ -95,8 +109,8 @@ resultWord = fmap fromIntegral  databaseNeedsUpgrade :: Database -> IO Bool-databaseNeedsUpgrade (Database db) =-    resultBool $ f_notmuch_database_needs_upgrade db+databaseNeedsUpgrade db = withDatabase db $+    resultBool . f_notmuch_database_needs_upgrade  statusCheck :: CInt -> IO () statusCheck 0 = return ()@@ -107,37 +121,65 @@ type UpgradeCallback = String -> Double -> IO ()  databaseUpgrade :: Database -> Maybe UpgradeCallback -> IO ()-databaseUpgrade (Database db) (Just callback) = do-  let ccb msg progress = do-        cmsg <- peekCString msg-        let cprogress = realToFrac progress-        callback cmsg cprogress-  cb <- w_notmuch_database_upgrade_1 ccb-  s <- f_notmuch_database_upgrade db cb nullPtr-  statusCheck s-databaseUpgrade (Database db) Nothing = do-  s <- f_notmuch_database_upgrade db nullFunPtr nullPtr-  statusCheck s+databaseUpgrade db (Just callback) = +  withDatabase db $ \dbp -> do+    let ccb msg progress = do+          cmsg <- peekCString msg+          let cprogress = realToFrac progress+          callback cmsg cprogress+    cb <- w_notmuch_database_upgrade_1 ccb+    s <- f_notmuch_database_upgrade dbp cb nullPtr+    statusCheck s+databaseUpgrade db Nothing = +  withDatabase db $ \dbp -> do+    s <- f_notmuch_database_upgrade dbp nullFunPtr nullPtr+    statusCheck s +databaseBeginAtomic :: Database -> IO ()+databaseBeginAtomic db =+  withDatabase db $ \dbp -> do+    s <- f_notmuch_database_begin_atomic dbp+    statusCheck s++databaseEndAtomic :: Database -> IO ()+databaseEndAtomic db =+  withDatabase db $ \dbp -> do+    s <- f_notmuch_database_end_atomic dbp+    statusCheck s+ newtype Directory = Directory (ForeignPtr S__notmuch_directory)  databaseGetDirectory :: Database -> FilePath -> IO Directory-databaseGetDirectory (Database db) path = withCString path $ (\p -> do-  dir <- f_notmuch_database_get_directory db p-  dirp <- newForeignPtr pf_notmuch_directory_destroy dir-  return $ Directory dirp)+databaseGetDirectory db path = alloca dirFun where+  dirFun dirPtr = withDatabase db $ \dbp -> do+    let getDirectory pathp =+          f_notmuch_database_get_directory dbp pathp dirPtr+    s <- withCString path getDirectory+    statusCheck s+    cdir <- peek dirPtr+    dir <- newForeignPtr pf_notmuch_directory_destroy cdir+    return $ Directory dir    type MessagesPtr = ForeignPtr S__notmuch_messages  type MessagePtr = ForeignPtr S__notmuch_message -data MessagesRef = QueryMessages { qmpp :: Query, msp :: MessagesPtr }-                 | ThreadMessages { tmpp :: Thread, msp :: MessagesPtr }-                 | MessageMessages { mmspp :: Message, msp :: MessagesPtr }+data MessagesRef = QueryMessages  Query MessagesPtr+                 | ThreadMessages Thread MessagesPtr+                 | MessageMessages Message MessagesPtr -data Message = MessagesMessage { msmpp :: MessagesRef, mp :: MessagePtr }-             | Message { mp :: MessagePtr }+msp :: MessagesRef -> MessagesPtr+msp (QueryMessages _ m) = m+msp (ThreadMessages _ m) = m+msp (MessageMessages _ m) = m +data Message = MessagesMessage MessagesRef MessagePtr+             | Message MessagePtr++mp :: Message -> MessagePtr+mp (MessagesMessage _ m) = m+mp (Message m) = m+ type Messages = [Message]  -- XXX We provide no way to request a null message pointer,@@ -148,10 +190,10 @@ -- succeed.  I have no idea what it should do, and this -- was easiest. databaseAddMessage :: Database -> FilePath -> IO Message-databaseAddMessage (Database db) filename = alloca msgFun where-    msgFun msgPtr = do+databaseAddMessage db filename = alloca msgFun where+    msgFun msgPtr = withDatabase db $ \dbp -> do       let addMessage fn =-              f_notmuch_database_add_message db fn msgPtr+              f_notmuch_database_add_message dbp fn msgPtr       s <- withCString filename addMessage       statusCheck s       cmsg <- peek msgPtr@@ -162,32 +204,34 @@ -- succeed.  I have no idea what it should do, and this -- was easiest. databaseRemoveMessage :: Database -> FilePath -> IO ()-databaseRemoveMessage (Database db) filename = do-  let removeMessage fn = f_notmuch_database_remove_message db fn-  s <- withCString filename removeMessage-  statusCheck s+databaseRemoveMessage db filename = +  withDatabase db $ \dbp -> do+    let removeMessage fn = f_notmuch_database_remove_message dbp fn+    s <- withCString filename removeMessage+    statusCheck s  -- XXX This might want to return a Maybe Message instead -- of failing if the message is not found.  I don't quite -- understand the use case yet. databaseFindMessage :: Database -> String -> IO Message-databaseFindMessage (Database db) msgid = do-  let findMessage mid =-          f_notmuch_database_find_message db mid-  cmsg <- withCString msgid findMessage-  when (cmsg == nullPtr) $-       fail "database find message failed"-  m <- newForeignPtr pf_notmuch_message_destroy cmsg-  return $ Message m+databaseFindMessage db msgid = alloca msgFun where+  msgFun msgPtr = withDatabase db $ \dbp -> do+    let findMessage mid =+          f_notmuch_database_find_message dbp mid msgPtr+    s <- withCString msgid findMessage+    statusCheck s+    cmsg <- peek msgPtr+    msg <- newForeignPtr pf_notmuch_message_destroy cmsg+    return $ Message msg    iterM :: Monad m => a -> (a -> m Bool) -> (a -> m b) -> m [b]-iterM coln test get = go [] coln test get-    where go acc coln test get = do+iterM coln test get = go []+    where go acc = do             cont <- test coln             case cont of               True -> do-                elem <- get coln-                go (elem : acc) coln test get+                e <- get coln+                go (e : acc)               False -> return acc  iterUnpack :: Ptr a -> (Ptr a -> IO CInt) ->@@ -217,8 +261,8 @@   databaseGetAllTags :: Database -> IO Tags-databaseGetAllTags (Database db) = do-  tags <- f_notmuch_database_get_all_tags db+databaseGetAllTags db = do+  tags <- withDatabase db $ f_notmuch_database_get_all_tags   when (tags == nullPtr) $        fail "database get all tags failed"   unpackTags tags@@ -226,13 +270,19 @@ newtype Query = Query (ForeignPtr S__notmuch_query)  queryCreate :: Database -> String -> IO Query-queryCreate (Database db) queryString = do-    query <- withCString queryString $ f_notmuch_query_create db+queryCreate db queryString = +  withDatabase db $ \dbp -> do+    query <- withCString queryString (f_notmuch_query_create dbp)     when (query == nullPtr) $-         fail "query create failed"+      fail "query create failed"     queryp <- newForeignPtr pf_notmuch_query_destroy query     return $ Query queryp +querySetOmitExcluded :: Query -> Bool -> IO ()+querySetOmitExcluded (Query query) omit = +  withForeignPtr query $ \q ->+    f_notmuch_query_set_omit_excluded q (fromIntegral (fromEnum omit))+ -- XXX Deriving Enum will only work if these fields are in -- the same order as in notmuch.h and there are no gaps -- there.@@ -253,29 +303,34 @@  type ThreadPtr = ForeignPtr S__notmuch_thread -data ThreadsRef = QueryThreads { qtspp :: Query,-                                 tsp :: ThreadsPtr }+data ThreadsRef = QueryThreads Query ThreadsPtr -data Thread = QueryThread { qtpp :: Query,-                            tp :: ThreadPtr }-            | ThreadsThread { ttpp :: ThreadsRef,-                              tp :: ThreadPtr }+data Thread = QueryThread Query ThreadPtr+            | ThreadsThread ThreadsRef ThreadPtr +tp :: Thread -> ThreadPtr+tp (QueryThread _ t) = t+tp (ThreadsThread _ t) = t+ type Threads = [Thread] +queryCountThreads :: Query -> IO Word+queryCountThreads (Query query) =+    withForeignPtr query $ resultWord . f_notmuch_query_count_threads+ queryThreads :: Query -> IO Threads queryThreads (Query query) = withForeignPtr query $ \q -> do   threads <- f_notmuch_query_search_threads q   when (threads == nullPtr) $        fail "query threads failed"-  tsp <- newForeignPtr pf_notmuch_threads_destroy threads-  let qts = QueryThreads (Query query) tsp+  t <- newForeignPtr pf_notmuch_threads_destroy threads+  let qts = QueryThreads (Query query) t   iterUnpack threads       f_notmuch_threads_valid       (\ts -> do-         t <- f_notmuch_threads_get ts-         tp <- newForeignPtr pf_notmuch_thread_destroy t-         let tst = ThreadsThread qts tp+         t' <- f_notmuch_threads_get ts+         t'' <- newForeignPtr pf_notmuch_thread_destroy t'+         let tst = ThreadsThread qts t''          return tst)       f_notmuch_threads_move_to_next @@ -285,8 +340,8 @@       f_notmuch_messages_valid       (\t -> do          m <- f_notmuch_messages_get t-         mp <- newForeignPtr pf_notmuch_message_destroy m-         let msm = MessagesMessage messages mp+         m' <- newForeignPtr pf_notmuch_message_destroy m+         let msm = MessagesMessage messages m'          return msm)       f_notmuch_messages_move_to_next @@ -399,7 +454,7 @@   peekCString path  data MessageFlag =-    MessageFlagMatch+    MessageFlagMatch | MessageFlagExcluded     deriving Enum               messageGetFlag :: Message -> MessageFlag -> IO Bool@@ -458,10 +513,10 @@  directorySetMtime :: Directory -> UTCTime -> IO () directorySetMtime (Directory dir) time = withForeignPtr dir $ \d -> do-  let t = fromIntegral $ floor $ realToFrac $ utcTimeToPOSIXSeconds time+  let t = floor $ utcTimeToPOSIXSeconds time :: Integer   when (t <= 0) $        fail "directory set mtime with invalid mtime"-  s <- f_notmuch_directory_set_mtime d t+  s <- f_notmuch_directory_set_mtime d (fromIntegral t)   statusCheck s  directoryGetMtime :: Directory -> IO UTCTime

@@ -12,7 +12,6 @@  import Control.Monad import Data.Time-import IO import System.Environment import System.Locale     @@ -21,6 +20,7 @@ dateString :: FormatTime t => t -> String dateString = formatTime defaultTimeLocale "%c" +main :: IO () main = do   argv <- getArgs   db <- if (length argv == 0)@@ -47,18 +47,21 @@   nthreadss <- mapM threadCountMessages threads   putStr $ show (sum nthreadss) ++ "/" ++ show (length threads) ++ ": "   print nthreadss-  let thread = last threads-  subject <- threadGetSubject thread-  putStrLn subject-  messages <- threadGetToplevelMessages thread-  let message = head messages-  subject' <- messageGetHeader message "Subject"-  putStrLn subject'-  date' <- messageGetHeader message "Date"-  putStrLn date'-  date <- messageGetDate message-  putStrLn $ dateString date-  localdate <- utcToLocalZonedTime date-  putStrLn $ dateString localdate+  case threads of+    [] -> return ()+    _ -> do+      let thread = last threads+      subject <- threadGetSubject thread+      putStrLn subject+      messages <- threadGetToplevelMessages thread+      let message = head messages+      subject' <- messageGetHeader message "Subject"+      putStrLn subject'+      date' <- messageGetHeader message "Date"+      putStrLn date'+      date <- messageGetDate message+      putStrLn $ dateString date+      localdate <- utcToLocalZonedTime date+      putStrLn $ dateString localdate   databaseClose db   return ()

@@ -1,5 +1,5 @@ Name: notmuch-haskell-Version: 0.2.2+Version: 1.0.0.3 Cabal-Version: >= 1.6 Author: Bart Massey <bart@cs.pdx.edu> Maintainer: Bart Massey <bart@cs.pdx.edu>@@ -12,17 +12,30 @@ Stability: Experimental Bug-Reports: mailto:bart@cs.pdx.edu Description:-   This is a very preliminary higher-level Haskell binding+   This is a half-assed higher-level Haskell binding    for the Notmuch (notmuchmail.org) email indexing library.  Library-  Build-Depends: base, containers, time, filepath+  Build-Depends: base >= 4.5 && < 6, containers >= 0.4.2 && < 5,+                 time >= 1.4 && < 2, filepath >= 0.1.3 && < 2   Exposed-Modules: Foreign.Notmuch   Other-Modules: Foreign.NOTMUCH_H-  Extra-Libraries: notmuch gmime-2.4 z nsl gobject-2.0 glib-2.0 talloc xapian+  Extra-Libraries: notmuch+  GHC-Options: -Wall  Executable notmuch-test   main-is: NotmuchTest.hs   other-modules: Foreign.Notmuch Foreign.NOTMUCH_H-  build-depends: base >= 4 && < 5, haskell98, old-locale, parseargs+  build-depends: base >= 4.5 && < 6, old-locale >= 1 && < 2,+                 parseargs >= 0.1.3 && < 2   Extra-Libraries: notmuch+  GHC-Options: -Wall++Source-repository head+  type: git+  location: git://github.com/BartMassey/notmuch-haskell.git++Source-repository this+  type: git+  location: git://github.com/BartMassey/notmuch-haskell.git+  tag: v1.0.0.3