{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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 Xmobar.Plugins.Mail(Mail(..),MailX(..)) where

import Xmobar.Run.Exec
#ifdef INOTIFY

import Xmobar.Plugins.Monitors.Common (parseOptsWith)
import Xmobar.System.Utils (expandHome, changeLoop)

import Control.Monad
import Control.Concurrent.STM

import System.Directory
import System.FilePath
import System.INotify
import System.Console.GetOpt

import Data.List (isPrefixOf)
import Data.Set (Set)
import qualified Data.Set as S

#if MIN_VERSION_hinotify(0,3,10)
import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack)
unpack :: BS.ByteString -> String
unpack :: ByteString -> String
unpack = ByteString -> String
BS.unpack
pack :: String -> BS.ByteString
pack :: String -> ByteString
pack = String -> ByteString
BS.pack
#else
unpack :: String -> String
unpack = id
pack :: String -> String
pack = id
#endif
#else
import System.IO
#endif

data MOptions = MOptions
               { MOptions -> String
oDir :: FilePath
               , MOptions -> String
oPrefix :: String
               , MOptions -> String
oSuffix :: String
               }

defaults :: MOptions
defaults :: MOptions
defaults = MOptions {oDir :: String
oDir = String
"", oPrefix :: String
oPrefix = String
"", oSuffix :: String
oSuffix = String
""}

options :: [OptDescr (MOptions -> MOptions)]
options :: [OptDescr (MOptions -> MOptions)]
options =
  [ String
-> [String]
-> ArgDescr (MOptions -> MOptions)
-> String
-> OptDescr (MOptions -> MOptions)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"d" [String
"dir"] ((String -> MOptions -> MOptions)
-> String -> ArgDescr (MOptions -> MOptions)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
x MOptions
o -> MOptions
o { oDir = x }) String
"") String
""
  , String
-> [String]
-> ArgDescr (MOptions -> MOptions)
-> String
-> OptDescr (MOptions -> MOptions)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"p" [String
"prefix"] ((String -> MOptions -> MOptions)
-> String -> ArgDescr (MOptions -> MOptions)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
x MOptions
o -> MOptions
o { oPrefix = x }) String
"") String
""
  , String
-> [String]
-> ArgDescr (MOptions -> MOptions)
-> String
-> OptDescr (MOptions -> MOptions)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"s" [String
"suffix"] ((String -> MOptions -> MOptions)
-> String -> ArgDescr (MOptions -> MOptions)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
x MOptions
o -> MOptions
o { oSuffix = x }) String
"") String
""
  ]

-- | A list of mail box names and paths to maildirs.
data Mail = Mail [(String, FilePath)] String
    deriving (ReadPrec [Mail]
ReadPrec Mail
Int -> ReadS Mail
ReadS [Mail]
(Int -> ReadS Mail)
-> ReadS [Mail] -> ReadPrec Mail -> ReadPrec [Mail] -> Read Mail
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Mail
readsPrec :: Int -> ReadS Mail
$creadList :: ReadS [Mail]
readList :: ReadS [Mail]
$creadPrec :: ReadPrec Mail
readPrec :: ReadPrec Mail
$creadListPrec :: ReadPrec [Mail]
readListPrec :: ReadPrec [Mail]
Read, Int -> Mail -> ShowS
[Mail] -> ShowS
Mail -> String
(Int -> Mail -> ShowS)
-> (Mail -> String) -> ([Mail] -> ShowS) -> Show Mail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mail -> ShowS
showsPrec :: Int -> Mail -> ShowS
$cshow :: Mail -> String
show :: Mail -> String
$cshowList :: [Mail] -> ShowS
showList :: [Mail] -> ShowS
Show)

-- | A list of mail box names, paths to maildirs and display colors.
data MailX = MailX [(String, FilePath, String)] [String] String
    deriving (ReadPrec [MailX]
ReadPrec MailX
Int -> ReadS MailX
ReadS [MailX]
(Int -> ReadS MailX)
-> ReadS [MailX]
-> ReadPrec MailX
-> ReadPrec [MailX]
-> Read MailX
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MailX
readsPrec :: Int -> ReadS MailX
$creadList :: ReadS [MailX]
readList :: ReadS [MailX]
$creadPrec :: ReadPrec MailX
readPrec :: ReadPrec MailX
$creadListPrec :: ReadPrec [MailX]
readListPrec :: ReadPrec [MailX]
Read, Int -> MailX -> ShowS
[MailX] -> ShowS
MailX -> String
(Int -> MailX -> ShowS)
-> (MailX -> String) -> ([MailX] -> ShowS) -> Show MailX
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MailX -> ShowS
showsPrec :: Int -> MailX -> ShowS
$cshow :: MailX -> String
show :: MailX -> String
$cshowList :: [MailX] -> ShowS
showList :: [MailX] -> ShowS
Show)

instance Exec Mail where
  alias :: Mail -> String
alias (Mail [(String, String)]
_ String
a) = String
a
  start :: Mail -> (String -> IO ()) -> IO ()
start (Mail [(String, String)]
ms String
a) = MailX -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start ([(String, String, String)] -> [String] -> String -> MailX
MailX (((String, String) -> (String, String, String))
-> [(String, String)] -> [(String, String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
n,String
p) -> (String
n,String
p,String
"")) [(String, String)]
ms) [] String
a)

instance Exec MailX where
    alias :: MailX -> String
alias (MailX [(String, String, String)]
_ [String]
_ String
a) = String
a
#ifndef INOTIFY
    start _ _ =
        hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify,"
                        ++ " but the Mail plugin requires it."
#else
    start :: MailX -> (String -> IO ()) -> IO ()
start (MailX [(String, String, String)]
ms [String]
args String
_) String -> IO ()
cb = do
        vs <- ((String, String, String) -> IO (TVar (Set String)))
-> [(String, String, String)] -> IO [TVar (Set String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO (TVar (Set String))
-> (String, String, String) -> IO (TVar (Set String))
forall a b. a -> b -> a
const (IO (TVar (Set String))
 -> (String, String, String) -> IO (TVar (Set String)))
-> IO (TVar (Set String))
-> (String, String, String)
-> IO (TVar (Set String))
forall a b. (a -> b) -> a -> b
$ Set String -> IO (TVar (Set String))
forall a. a -> IO (TVar a)
newTVarIO Set String
forall a. Set a
S.empty) [(String, String, String)]
ms
        opts <- parseOptsWith options defaults args
        let prefix = MOptions -> String
oPrefix MOptions
opts
            suffix = MOptions -> String
oSuffix MOptions
opts
            dir = MOptions -> String
oDir MOptions
opts
            ps = ((String, String, String) -> String)
-> [(String, String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
_,String
p,String
_) -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dir then String
p else String
dir String -> ShowS
</> String
p) [(String, String, String)]
ms
            rs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
</> String
"new") [String]
ps
            ev = [EventVariety
Move, EventVariety
MoveIn, EventVariety
MoveOut, EventVariety
Create, EventVariety
Delete]

        ds <- mapM expandHome rs
        i <- initINotify
        zipWithM_ (\ByteString
d TVar (Set String)
v -> INotify
-> [EventVariety]
-> ByteString
-> (Event -> IO ())
-> IO WatchDescriptor
addWatch INotify
i [EventVariety]
ev ByteString
d (TVar (Set String) -> Event -> IO ()
handle TVar (Set String)
v)) (map pack ds) vs

        forM_ (zip ds vs) $ \(String
d, TVar (Set String)
v) -> do
            s <- ([String] -> Set String) -> IO [String] -> IO (Set String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ([String] -> [String]) -> [String] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"."))
                    (IO [String] -> IO (Set String)) -> IO [String] -> IO (Set String)
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
d
            atomically $ modifyTVar v (S.union s)

        changeLoop (mapM (fmap S.size . readTVar) vs) $ \[Int]
ns ->
            let showmbx :: String -> a -> ShowS
showmbx String
m a
n String
c = if String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
                                then String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
                                else String
"<fc=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</fc>"
                cnts :: [String]
cnts = [String -> Int -> ShowS
forall {a}. Show a => String -> a -> ShowS
showmbx String
m Int
n String
c | ((String
m,String
_,String
c), Int
n) <- [(String, String, String)]
-> [Int] -> [((String, String, String), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, String, String)]
ms [Int]
ns , Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 ]
            in String -> IO ()
cb (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cnts then String
"" else String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
cnts String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix

handle :: TVar (Set String) -> Event -> IO ()
handle :: TVar (Set String) -> Event -> IO ()
handle TVar (Set String)
v Event
e = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set String) -> (Set String -> Set String) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set String)
v ((Set String -> Set String) -> STM ())
-> (Set String -> Set String) -> STM ()
forall a b. (a -> b) -> a -> b
$ case Event
e of
    Created  {} -> Set String -> Set String
create
    MovedIn  {} -> Set String -> Set String
create
    Deleted  {} -> Set String -> Set String
delete
    MovedOut {} -> Set String -> Set String
delete
    Event
_           -> Set String -> Set String
forall a. a -> a
id
 where
    delete :: Set String -> Set String
delete = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.delete ((ByteString -> String
unpack (ByteString -> String) -> (Event -> ByteString) -> Event -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ByteString
filePath) Event
e)
    create :: Set String -> Set String
create = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert ((ByteString -> String
unpack (ByteString -> String) -> (Event -> ByteString) -> Event -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ByteString
filePath) Event
e)
#endif