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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Notmuch where
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Network.Mail.Mime as M
import Data.Aeson.Extends
import Data.Either.Combinators (mapRight)
import Data.Functor ((<&>))
import Data.Tree
import Notmuch.Class
import Notmuch.Message
import Notmuch.SearchResult
import Much.ParseMail (readMail)
import System.Exit
import System.Process.ByteString.Lazy (readProcessWithExitCode)
import Much.TagUtils
notmuch :: [String] -> IO LBS.ByteString
notmuch args = do
(_exitCode, out, _err) <- notmuch' args
return out
notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
notmuch' args =
readProcessWithExitCode "notmuch" args ""
search :: [String] -> IO (Either String [SearchResult])
search args =
eitherDecodeLenient' <$>
notmuch ("search" : "--format=json" : "--format-version=2" : args)
data ReplyTo = ToAll | ToSender
instance Show ReplyTo where
show ToAll = "all"
show ToSender = "sender"
--notmuchReply :: String -> IO (Either String [SearchResult])
notmuchReply :: ReplyTo -> String -> IO LBS.ByteString
notmuchReply replyTo term =
notmuch
[ "reply"
, "--reply-to=" ++ show replyTo
, term
]
-- >>= return . eitherDecodeLenient'
notmuchShow :: String -> IO (Forest Message)
notmuchShow term = do
c' <- notmuch [ "show", "--format=json", "--format-version=2"
, term ]
-- TODO why head?
return $ threadForest $ head $
either error id (eitherDecodeLenient' c')
notmuchShowPartRaw :: String -> Int -> IO (Either String LBS8.ByteString)
notmuchShowPartRaw term partId = do
(exitCode, out, err) <-
notmuch' [ "show", "--format=raw"
, "--part=" <> show partId
, term ]
return $ case exitCode of
ExitSuccess -> Right out
_ -> Left $ show exitCode <> ": " <> LBS8.unpack err
notmuchShowPart :: String -> Int -> IO (Either String MessagePart)
notmuchShowPart term partId = do
-- TODO handle partId == 0 and partId > N
(exitCode, out, err) <-
notmuch' [ "show", "--format=json", "--format-version=2"
, "--part=" <> show partId
, term ]
case exitCode of
ExitSuccess ->
case eitherDecodeLenient' out of
Right mp -> do
case partContent mp of
ContentRaw "" contentLength ->
notmuchShowPartRaw term partId <&> mapRight (\raw ->
mp { partContent = ContentRaw raw contentLength }
)
_ ->
return $ Right mp
Left err2 ->
return $ Left err2
_ ->
return $ Left $ show exitCode <> ": " <> LBS8.unpack err
notmuchShowMail :: String -> IO (Either String M.Mail)
notmuchShowMail term =
notmuch' [ "show", "--format=raw", "--format-version=2", term ]
>>= return . \case
(ExitSuccess, out, _) ->
case LT.decodeUtf8' out of
Right x -> Right (readMail $ LT.toStrict x)
Left ex -> Left $ "meh" ++ show ex
(exitCode, _, err) ->
Left $ "notmuch failed with exit code " ++ show exitCode ++
": " ++ LBS8.unpack err
notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO ()
notmuchTag tagOps x =
notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return ()
|
