blob: 232f4643dbc3bc96f7304a0bd7c83f092232e50d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Mail
-- Copyright : (c) Spencer Janssen
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu>
-- Stability : unstable
-- Portability : unportable
--
-- A plugin for checking mail.
--
-----------------------------------------------------------------------------
module Plugins.Mail where
import Prelude hiding (catch)
import System.IO
import Plugins
import Control.Monad
import Control.Concurrent.STM
import System.Directory
import System.FilePath
import System.INotify
import Data.List (isPrefixOf)
import Data.Set (Set)
import qualified Data.Set as S
-- | A list of mail box names and paths to maildirs.
data Mail = Mail [(String, FilePath)]
deriving (Read, Show)
instance Exec Mail where
start (Mail ms) cb = do
vs <- mapM (const $ newTVarIO S.empty) ms
let ts = map fst ms
ds = map ((</> "new") . snd) ms
ev = [Move, MoveIn, MoveOut, Create, Delete]
i <- initINotify
zipWithM_ (\d v -> addWatch i ev d (handle v)) ds vs
forM (zip ds vs) $ \(d, v) -> do
s <- fmap (S.fromList . filter (not . isPrefixOf "."))
$ getDirectoryContents d
atomically $ modifyTVar v (S.union s)
changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> do
cb . unwords $ [m ++ ":" ++ show n
| (m, n) <- zip ts ns
, n /= 0 ]
modifyTVar :: TVar a -> (a -> a) -> STM ()
modifyTVar v f = readTVar v >>= writeTVar v . f
handle :: TVar (Set String) -> Event -> IO ()
handle v e = atomically $ modifyTVar v $ case e of
Created {} -> create
MovedIn {} -> create
Deleted {} -> delete
MovedOut {} -> delete
_ -> id
where
delete = S.delete (filePath e)
create = S.insert (filePath e)
changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO ()
changeLoop s f = atomically s >>= go
where
go old = do
f old
go =<< atomically (do
new <- s
guard (new /= old)
return new)
|
