{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module UI.Actions (
Scrollable(..)
, Completable(..)
, HasEditor(..)
, HasName(..)
, quit
, continue
, edit
, invokeEditor
, openWithCommand
, pipeToCommand
, focus
, done
, abort
, noop
, chain
, chain'
, listUp
, listDown
, listJumpToEnd
, listJumpToStart
, reloadList
, toggleListItem
, untoggleListItems
, displayMail
, setUnread
, displayThreadMails
, toggleHeaders
, switchComposeEditor
, replyMail
, encapsulateMail
, selectNextUnread
, composeAsNew
, createAttachments
, openAttachment
, setTags
, saveAttachmentToPath
, scrollUp
, scrollDown
, scrollPageUp
, scrollPageDown
, scrollNextWord
, removeHighlights
, delete
, enterDirectory
, parentDirectory
, handleConfirm
, applySearch
, initialCompose
) where
import qualified Brick
import Brick.BChan (writeBChan)
import qualified Brick.Focus as Brick
import qualified Brick.Types as T
import qualified Brick.Widgets.Edit as E
import qualified Brick.Widgets.List as L
import Brick.Widgets.Dialog (dialog, dialogSelection, Dialog)
import Network.Mime (defaultMimeLookup)
import Data.Proxy
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LB
import Data.Attoparsec.ByteString.Char8 (parseOnly)
import qualified Data.Attoparsec.Text as AT (parseOnly)
import Data.Vector.Lens (vector)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List (union)
import System.FilePath (takeDirectory, (</>))
import qualified Data.Vector as Vector
import Prelude hiding (readFile, unlines)
import Data.Foldable (toList, traverse_)
import Data.Functor.Identity (Identity(..))
import Control.Lens
(_Just, to, at, ix, _1, _2, toListOf, traverse, traversed, has,
filtered, set, over, preview, view, (&), firstOf, non, Traversal',
Getting, Lens', folded, assign, modifying, preuse, use, uses
, Ixed, Index, IxValue)
import Control.Concurrent (forkIO)
import Control.Monad (void)
import Control.Monad.State
import Control.Monad.Catch (MonadCatch, MonadMask, catch)
import Control.Monad.Except (runExceptT, MonadError)
import Control.Exception (IOException)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Text.Zipper
(insertMany, currentLine, gotoEOL, clearZipper, TextZipper)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getZonedTime, zonedTimeToUTC)
import qualified Data.RFC5322.Address.Text as AddressText
( renderMailboxes, addressList, mailboxList )
import Data.MIME
(createMultipartMixedMessage, contentTypeApplicationOctetStream,
createTextPlainMessage, createAttachmentFromFile, buildMessage,
contentDisposition, dispositionType, headers, filename,
parseContentType, attachments, entities, matchContentType,
contentType,
encapsulate, MIMEMessage, WireEntity, DispositionType(..),
ContentType(..), Mailbox(..),
CharsetLookup, headerDate, headerTo, headerFrom, headerSubject)
import qualified Storage.Notmuch as Notmuch
import Storage.ParsedMail
( parseMail, getTo, getFrom, getSubject, getForwardedSubject, toQuotedMail
, entityToBytes, toMIMEMessage, takeFileName, bodyToDisplay
, removeMatchingWords, findMatchingWords, makeScrollSteps
, writeEntityToPath)
import Types
import Error
import UI.Views
(mailView, toggleLastVisibleWidget, indexView, resetView,
focusedViewWidget)
import Purebred.Events (nextGeneration)
import Purebred.LazyVector (V)
import Purebred.Tags (parseTagOps)
import Purebred.System (tryIO)
import Purebred.System.Directory (listDirectory')
import Purebred.System.Process
class Scrollable (n :: Name) where
makeViewportScroller :: Proxy n -> Brick.ViewportScroll Name
instance Scrollable 'ScrollingMailView where
makeViewportScroller _ = Brick.viewportScroll ScrollingMailView
instance Scrollable 'ScrollingHelpView where
makeViewportScroller _ = Brick.viewportScroll ScrollingHelpView
class HasEditor (n :: Name) where
editorL :: Proxy n -> Lens' AppState (E.Editor T.Text Name)
instance HasEditor 'ComposeFrom where
editorL _ = asCompose . cFrom
instance HasEditor 'ComposeTo where
editorL _ = asCompose . cTo
instance HasEditor 'ComposeCc where
editorL _ = asCompose . cCc
instance HasEditor 'ComposeBcc where
editorL _ = asCompose . cBcc
instance HasEditor 'ComposeSubject where
editorL _ = asCompose . cSubject
instance HasEditor 'ManageMailTagsEditor where
editorL _ = asMailIndex . miMailTagsEditor
instance HasEditor 'MailAttachmentOpenWithEditor where
editorL _ = asMailView . mvOpenCommand
instance HasEditor 'MailAttachmentPipeToEditor where
editorL _ = asMailView . mvPipeCommand
instance HasEditor 'ScrollingMailViewFindWordEditor where
editorL _ = asMailView . mvFindWordEditor
instance HasEditor 'SearchThreadsEditor where
editorL _ = asMailIndex . miSearchThreadsEditor
instance HasEditor 'ManageThreadTagsEditor where
editorL _ = asMailIndex . miThreadTagsEditor
instance HasEditor 'SaveToDiskPathEditor where
editorL _ = asMailView . mvSaveToDiskPath
class HasList (n :: Name) where
type T n :: * -> *
type E n
list :: Proxy n -> Lens' AppState (L.GenericList Name (T n) (E n))
instance HasList 'ListOfThreads where
type T 'ListOfThreads = V
type E 'ListOfThreads = Toggleable NotmuchThread
list _ = asMailIndex . miListOfThreads
instance HasList 'ListOfMails where
type T 'ListOfMails = Vector.Vector
type E 'ListOfMails = Toggleable NotmuchMail
list _ = asMailIndex . miListOfMails
instance HasList 'ScrollingMailView where
type T 'ScrollingMailView = Vector.Vector
type E 'ScrollingMailView = Toggleable NotmuchMail
list _ = asMailIndex . miListOfMails
instance HasList 'ComposeListOfAttachments where
type T 'ComposeListOfAttachments = Vector.Vector
type E 'ComposeListOfAttachments = MIMEMessage
list _ = asCompose . cAttachments
instance HasList 'MailListOfAttachments where
type T 'MailListOfAttachments = Vector.Vector
type E 'MailListOfAttachments = WireEntity
list _ = asMailView . mvAttachments
instance HasList 'ListOfFiles where
type T 'ListOfFiles = Vector.Vector
type E 'ListOfFiles = Toggleable FileSystemEntry
list _ = asFileBrowser . fbEntries
class (HasList (n :: Name), Traversable (T n)) =>
HasToggleableList n
where
untoggleE :: Proxy n -> E n -> E n
toggleE :: Proxy n -> E n -> E n
isToggledE :: Proxy n -> E n -> Bool
untoggleAll :: (MonadState AppState m) => Proxy n -> m ()
untoggleAll proxy = modifying (list proxy . traversed) (untoggleE proxy)
toggle :: Proxy n -> Int -> StateT AppState (T.EventM Name) ()
toggledItemsL :: Proxy n -> Traversal' AppState (E n)
toggledItemsL proxy = list proxy . traversed . filtered (isToggledE proxy)
instance
( HasList n
, Traversable (T n)
, E n ~ (Bool, a)
, Index (T n (Bool, a)) ~ Int
, IxValue (T n (Bool, a)) ~ (Bool, a)
, Ixed (T n (Bool, a))
) => HasToggleableList n where
untoggleE _ = set _1 False
toggleE _ = over _1 not
isToggledE _ = fst
toggle proxy i = modifying (list proxy . L.listElementsL . ix i) (toggleE proxy)
class Completable (n :: Name) where
complete :: (MonadIO m, MonadMask m, MonadState AppState m) => Proxy n -> m ()
instance Completable 'SearchThreadsEditor where
complete _ = applySearch
instance Completable 'ManageMailTagsEditor where
complete _ = do
get >>= liftIO . completeMailTags >>= put
modifying (asMailIndex . miMailTagsEditor . E.editContentsL) clearZipper
instance Completable 'ComposeListOfAttachments where
complete _ = sendMail
completeMailTags :: AppState -> IO AppState
completeMailTags s =
case getEditorTagOps (Proxy @'ManageMailTagsEditor) s of
Left err -> pure $ setError err s
Right ops -> flip execStateT s $ do
modifying (asMailIndex . miListOfThreads) (L.listModify (over _2 $ Notmuch.tagItem ops))
toggledOrSelectedItemHelper
(Proxy @'ScrollingMailView)
(manageMailTags ops)
(over _2 (Notmuch.tagItem ops))
modify (toggleLastVisibleWidget ManageMailTagsEditor)
hide, unhide :: (MonadState AppState m) => ViewName -> Int -> Name -> m ()
hide = setViewState Hidden
unhide = setViewState Visible
setViewState :: (MonadState AppState m) => ViewState -> ViewName -> Int -> Name -> m ()
setViewState v n i m =
assign (asViews . vsViews . ix n . vLayers . ix i . ix m . veState) v
instance Completable 'ComposeTo where
complete _ = do
hide ComposeView 1 ComposeTo
hide ViewMail 0 ComposeTo
instance Completable 'ComposeCc where
complete _ = do
hide ComposeView 1 ComposeCc
hide ViewMail 0 ComposeCc
instance Completable 'ComposeBcc where
complete _ = do
hide ComposeView 1 ComposeBcc
hide ViewMail 0 ComposeBcc
instance Completable 'ComposeFrom where
complete _ = hide ComposeView 1 ComposeFrom
instance Completable 'ComposeSubject where
complete _ = hide ComposeView 1 ComposeSubject
instance Completable 'ConfirmDialog where
complete _ = hide ComposeView 0 ConfirmDialog
instance Completable 'ManageThreadTagsEditor where
complete _ = do
s <- get
case getEditorTagOps (Proxy @'ManageThreadTagsEditor) s of
Left err -> assignError err
Right ops -> do
toggledOrSelectedItemHelper
(Proxy @'ListOfThreads)
(manageThreadTags ops)
(over _2 (Notmuch.tagItem ops))
modify (toggleLastVisibleWidget SearchThreadsEditor)
instance Completable 'ManageFileBrowserSearchPath where
complete _ = do
paths <- use (asFileBrowser . fbSearchPath . E.editContentsL)
f <- either setError updateBrowseFileContents
<$> runExceptT (listDirectory' (currentLine paths))
modify f
instance Completable 'MailAttachmentOpenWithEditor where
complete _ = hide ViewMail 0 MailAttachmentOpenWithEditor
instance Completable 'MailAttachmentPipeToEditor where
complete _ = hide ViewMail 0 MailAttachmentPipeToEditor
instance Completable 'SaveToDiskPathEditor where
complete _ = hide ViewMail 0 SaveToDiskPathEditor
instance Completable 'ScrollingMailViewFindWordEditor where
complete _ = do
needle <- uses (asMailView . mvFindWordEditor . E.editContentsL) currentLine
body <- uses (asMailView . mvBody) (findMatchingWords needle)
hide ViewMail 0 ScrollingMailViewFindWordEditor
assign (asMailView . mvScrollSteps) (Brick.focusRing (makeScrollSteps body))
assign (asMailView . mvBody) body
class Resetable (v :: ViewName) (n :: Name) where
reset :: (MonadIO m, MonadState AppState m) => Proxy v -> Proxy n -> m ()
instance Resetable 'Threads 'SearchThreadsEditor where
reset _ _ = pure ()
instance Resetable 'ViewMail 'ManageMailTagsEditor where
reset _ _ = modifying (asMailIndex . miMailTagsEditor . E.editContentsL) clearZipper
instance Resetable 'Threads 'ManageThreadTagsEditor where
reset _ _ = do
modifying (asMailIndex . miThreadTagsEditor . E.editContentsL) clearZipper
modify (toggleLastVisibleWidget SearchThreadsEditor)
instance Resetable 'Threads 'ComposeFrom where
reset _ _ = modify clearMailComposition
instance Resetable 'Threads 'ComposeSubject where
reset _ _ = modify clearMailComposition
instance Resetable 'Threads 'ComposeTo where
reset _ _ = modify clearMailComposition
instance Resetable 'ComposeView 'ComposeFrom where
reset _ _ = do
s <- get
modifying (asCompose . cSubject . E.editContentsL) (revertEditorContents s)
hide ComposeView 1 ComposeFrom
instance Resetable 'ComposeView 'ComposeTo where
reset _ _ = do
s <- get
modifying (asCompose . cTo . E.editContentsL) (revertEditorContents s)
hide ComposeView 1 ComposeTo
instance Resetable 'ComposeView 'ComposeCc where
reset _ _ = do
s <- get
modifying (asCompose . cCc . E.editContentsL) (revertEditorContents s)
hide ComposeView 1 ComposeCc
instance Resetable 'ComposeView 'ComposeBcc where
reset _ _ = do
s <- get
modifying (asCompose . cBcc . E.editContentsL) (revertEditorContents s)
hide ComposeView 1 ComposeBcc
instance Resetable 'ComposeView 'ComposeSubject where
reset _ _ = do
s <- get
modifying (asCompose . cSubject . E.editContentsL) (revertEditorContents s)
hide ComposeView 1 ComposeSubject
revertEditorContents :: AppState -> TextZipper T.Text -> TextZipper T.Text
revertEditorContents s z = let saved = view (asCompose . cTemp) s
replace = insertMany saved . clearZipper
in replace z
instance Resetable 'ComposeView 'ComposeListOfAttachments where
reset _ _ = modify clearMailComposition
instance Resetable 'FileBrowser 'ManageFileBrowserSearchPath where
reset _ _ = modifying (asFileBrowser . fbSearchPath . E.editContentsL) clearZipper
instance Resetable 'ViewMail 'MailListOfAttachments where
reset _ _ = hide ViewMail 0 MailListOfAttachments
instance Resetable 'ViewMail 'MailAttachmentOpenWithEditor where
reset _ _ = do
modifying (asMailView . mvOpenCommand . E.editContentsL) clearZipper
hide ViewMail 0 MailAttachmentOpenWithEditor
instance Resetable 'ViewMail 'MailAttachmentPipeToEditor where
reset _ _ = do
modifying (asMailView . mvPipeCommand . E.editContentsL) clearZipper
hide ViewMail 0 MailAttachmentPipeToEditor
instance Resetable 'ViewMail 'ScrollingMailViewFindWordEditor where
reset _ _ = do
modifying (asMailView . mvFindWordEditor . E.editContentsL) clearZipper
hide ViewMail 0 ScrollingMailViewFindWordEditor
modify resetMatchingWords
instance Resetable 'ViewMail 'ScrollingMailView where
reset _ _ = modify resetMatchingWords
instance Resetable 'ViewMail 'SaveToDiskPathEditor where
reset _ _ = do
modifying (asMailView . mvSaveToDiskPath . E.editContentsL) clearZipper
hide ViewMail 0 SaveToDiskPathEditor
instance Resetable 'ViewMail 'ComposeTo where
reset _ _ = do
s <- get
modifying (asCompose . cTo . E.editContentsL) (revertEditorContents s)
hide ViewMail 0 ComposeTo
modify clearMailComposition
clearMailComposition :: AppState -> AppState
clearMailComposition s =
let mailboxes = view (asConfig . confComposeView . cvIdentities) s
in s
& set asCompose (initialCompose mailboxes)
. toggleLastVisibleWidget SearchThreadsEditor
class Focusable (v :: ViewName) (n :: Name) where
switchFocus :: (MonadState AppState m, MonadIO m) => Proxy v -> Proxy n -> m ()
instance Focusable 'Threads 'SearchThreadsEditor where
switchFocus _ _ = modifying (asMailIndex . miSearchThreadsEditor) (E.applyEdit gotoEOL)
instance Focusable 'Threads 'ManageThreadTagsEditor where
switchFocus _ _ = do
modifying (asMailIndex . miThreadTagsEditor . E.editContentsL) clearZipper
modify (toggleLastVisibleWidget ManageThreadTagsEditor)
instance Focusable 'Threads 'ComposeFrom where
switchFocus _ _ = do
modify (toggleLastVisibleWidget ComposeFrom)
modifying (asCompose . cFrom) (E.applyEdit gotoEOL)
instance Focusable 'Threads 'ComposeTo where
switchFocus _ _ = modify (toggleLastVisibleWidget ComposeTo)
instance Focusable 'Threads 'ComposeSubject where
switchFocus _ _ = modify (toggleLastVisibleWidget ComposeSubject)
instance Focusable 'Threads 'ListOfThreads where
switchFocus _ _ = pure ()
instance Focusable 'ViewMail 'ManageMailTagsEditor where
switchFocus _ _ = do
unhide ViewMail 0 ManageMailTagsEditor
assign (asViews . vsViews . ix ViewMail . vFocus) ManageMailTagsEditor
instance Focusable 'ViewMail 'ScrollingMailView where
switchFocus _ _ = assign (asViews . vsViews . ix ViewMail . vFocus) ScrollingMailView
instance Focusable 'ViewMail 'ScrollingMailViewFindWordEditor where
switchFocus _ _ = do
modifying (asMailView . mvFindWordEditor . E.editContentsL) clearZipper
assign (asViews. vsViews . ix ViewMail . vFocus) ScrollingMailViewFindWordEditor
unhide ViewMail 0 ScrollingMailViewFindWordEditor
instance Focusable 'ViewMail 'ListOfMails where
switchFocus _ _ = assign (asViews . vsViews . ix ViewMail . vFocus) ListOfMails
instance Focusable 'ViewMail 'MailListOfAttachments where
switchFocus _ _ = do
assign (asViews . vsViews . ix ViewMail . vFocus) MailListOfAttachments
unhide ViewMail 0 MailListOfAttachments
instance Focusable 'ViewMail 'MailAttachmentOpenWithEditor where
switchFocus _ _ = do
assign (asViews . vsViews . ix ViewMail . vFocus) MailAttachmentOpenWithEditor
unhide ViewMail 0 MailAttachmentOpenWithEditor
instance Focusable 'ViewMail 'MailAttachmentPipeToEditor where
switchFocus _ _ = do
assign (asViews . vsViews . ix ViewMail . vFocus) MailAttachmentPipeToEditor
unhide ViewMail 0 MailAttachmentPipeToEditor
instance Focusable 'ViewMail 'SaveToDiskPathEditor where
switchFocus _ _ = do
charsets <- use (asConfig . confCharsets)
s <- get
let maybeFilePath = preview (asMailView . mvAttachments . to L.listSelectedElement
. _Just . _2 . contentDisposition . folded . filename charsets) s
fname = view (non mempty) maybeFilePath
assign (asViews . vsViews . ix ViewMail . vFocus) SaveToDiskPathEditor
unhide ViewMail 0 SaveToDiskPathEditor
modifying (asMailView . mvSaveToDiskPath . E.editContentsL) (insertMany fname . clearZipper)
instance Focusable 'ViewMail 'ComposeTo where
switchFocus _ _ = do
assign (asViews . vsViews . ix ViewMail . vFocus) ComposeTo
unhide ViewMail 0 ComposeTo
instance Focusable 'Help 'ScrollingHelpView where
switchFocus _ _ = modifying (asViews . vsFocusedView) (Brick.focusSetCurrent Help)
instance Focusable 'ComposeView 'ComposeListOfAttachments where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeListOfAttachments
modify (resetView Threads indexView)
instance Focusable 'ComposeView 'ComposeFrom where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeFrom
curLine <- uses (asCompose . cTo . E.editContentsL) currentLine
assign (asCompose . cTemp) curLine
unhide ComposeView 1 ComposeFrom
instance Focusable 'ComposeView 'ComposeTo where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeTo
curLine <- uses (asCompose . cTo . E.editContentsL) currentLine
assign (asCompose . cTemp) curLine
unhide ComposeView 1 ComposeTo
instance Focusable 'ComposeView 'ComposeCc where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeCc
curLine <- uses (asCompose . cTo . E.editContentsL) currentLine
assign (asCompose . cTemp) curLine
unhide ComposeView 1 ComposeCc
instance Focusable 'ComposeView 'ComposeBcc where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeBcc
curLine <- uses (asCompose . cTo . E.editContentsL) currentLine
assign (asCompose . cTemp) curLine
unhide ComposeView 1 ComposeBcc
instance Focusable 'ComposeView 'ComposeSubject where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ComposeSubject
curLine <- uses (asCompose . cTo . E.editContentsL) currentLine
assign (asCompose . cTemp) curLine
unhide ComposeView 1 ComposeSubject
instance Focusable 'ComposeView 'ConfirmDialog where
switchFocus _ _ = do
assign (asViews . vsViews . ix ComposeView . vFocus) ConfirmDialog
unhide ComposeView 0 ConfirmDialog
instance Focusable 'FileBrowser 'ListOfFiles where
switchFocus _ _ = do
path <- uses (asFileBrowser . fbSearchPath . E.editContentsL) currentLine
runExceptT (listDirectory' path) >>= either
assignError
(\x -> do
modifying (asFileBrowser . fbSearchPath . E.editContentsL) (insertMany path . clearZipper)
modify (updateBrowseFileContents x))
instance Focusable 'FileBrowser 'ManageFileBrowserSearchPath where
switchFocus _ _ = pure ()
class HasName (a :: Name) where
name :: Proxy a -> Name
instance HasName 'ListOfMails where
name _ = ListOfMails
instance HasName 'SearchThreadsEditor where
name _ = SearchThreadsEditor
instance HasName 'ScrollingMailView where
name _ = ScrollingMailView
instance HasName 'ScrollingMailViewFindWordEditor where
name _ = ScrollingMailViewFindWordEditor
instance HasName 'ManageMailTagsEditor where
name _ = ManageMailTagsEditor
instance HasName 'ListOfThreads where
name _ = ListOfThreads
instance HasName 'ScrollingHelpView where
name _ = ScrollingHelpView
instance HasName 'ComposeFrom where
name _ = ComposeFrom
instance HasName 'ComposeTo where
name _ = ComposeTo
instance HasName 'ComposeCc where
name _ = ComposeCc
instance HasName 'ComposeBcc where
name _ = ComposeBcc
instance HasName 'ComposeSubject where
name _ = ComposeSubject
instance HasName 'ManageThreadTagsEditor where
name _ = ManageThreadTagsEditor
instance HasName 'ComposeListOfAttachments where
name _ = ComposeListOfAttachments
instance HasName 'ListOfFiles where
name _ = ListOfFiles
instance HasName 'ManageFileBrowserSearchPath where
name _ = ManageFileBrowserSearchPath
instance HasName 'MailListOfAttachments where
name _ = MailListOfAttachments
instance HasName 'MailAttachmentOpenWithEditor where
name _ = MailAttachmentOpenWithEditor
instance HasName 'MailAttachmentPipeToEditor where
name _ = MailAttachmentPipeToEditor
instance HasName 'ConfirmDialog where
name _ = ConfirmDialog
instance HasName 'SaveToDiskPathEditor where
name _ = SaveToDiskPathEditor
class ViewTransition (v :: ViewName) (v' :: ViewName) where
transitionHook :: Proxy v -> Proxy v' -> AppState -> AppState
transitionHook _ _ = id
instance ViewTransition v v where
instance ViewTransition 'Threads 'ComposeView where
instance ViewTransition 'Help v where
instance ViewTransition v 'Help where
instance ViewTransition 'ComposeView 'Threads where
instance ViewTransition 'ComposeView 'FileBrowser where
instance ViewTransition 'Threads 'ViewMail where
transitionHook _ _ = set (asViews . vsViews . ix ViewMail) mailView
instance ViewTransition 'ViewMail 'ComposeView where
instance ViewTransition 'FileBrowser 'ComposeView where
instance ViewTransition 'ViewMail 'Threads where
class HasViewName (a :: ViewName) where
viewname :: Proxy a -> ViewName
instance HasViewName 'Threads where
viewname _ = Threads
instance HasViewName 'ViewMail where
viewname _ = ViewMail
instance HasViewName 'Help where
viewname _ = Help
instance HasViewName 'ComposeView where
viewname _ = ComposeView
instance HasViewName 'FileBrowser where
viewname _ = FileBrowser
quit :: Action v ctx (T.Next AppState)
quit = Action ["quit the application"] (get >>= lift . Brick.halt)
continue :: Action v ctx (T.Next AppState)
continue = Action mempty (get >>= lift . Brick.continue)
invokeEditor :: Action v ctx (T.Next AppState)
invokeEditor = Action ["invoke external editor"] (stateSuspendAndResume $ invokeEditor' insertOrReplaceAttachment)
edit :: Action 'ComposeView 'ComposeListOfAttachments (T.Next AppState)
edit = Action ["edit file"] (stateSuspendAndResume editAttachment)
openAttachment :: Action 'ViewMail ctx (T.Next AppState)
openAttachment =
Action
{ _aDescription = ["open attachment with external command"]
, _aAction = do
s <- get
let
match ct = firstOf (asConfig . confMailView . mvMailcap . traversed
. filtered (`fst` ct)
. _2) s
maybeCommand =
match
=<< preview (asMailView . mvAttachments . to L.listSelectedElement . _Just . _2 . headers . contentType) s
case maybeCommand of
Just cmd -> openCommand' cmd *> get >>= (lift . Brick.continue)
Nothing -> do
let l = asViews . vsViews . ix ViewMail
assign (l . vFocus) MailAttachmentOpenWithEditor
assign (l . vLayers . ix 0 . ix MailAttachmentOpenWithEditor . veState) Visible
lift . Brick.continue =<< get
}
openWithCommand :: Action 'ViewMail 'MailAttachmentOpenWithEditor (T.Next AppState)
openWithCommand =
Action
{ _aDescription = ["ask for command to open attachment"]
, _aAction = do
cmd <- uses (asMailView . mvOpenCommand . E.editContentsL) (T.unpack . currentLine)
case cmd of
[] -> lift . Brick.continue . setError (GenericError "Empty command") =<< get
(x:xs) -> stateSuspendAndResume $
openCommand' (MailcapHandler (Process (x :| xs) []) IgnoreOutput DiscardTempfile)
}
stateSuspendAndResume :: StateT AppState IO a -> StateT AppState (T.EventM n) (T.Next AppState)
stateSuspendAndResume go = lift . Brick.suspendAndResume . execStateT (go *> get) =<< get
pipeToCommand :: Action 'ViewMail 'MailAttachmentPipeToEditor (T.Next AppState)
pipeToCommand =
Action
{ _aDescription = ["pipe to external command"]
, _aAction = do
cmd <- uses (asMailView . mvPipeCommand . E.editContentsL) (T.unpack . currentLine)
stateSuspendAndResume (pipeCommand' cmd)
}
saveAttachmentToPath :: Action 'ViewMail 'SaveToDiskPathEditor ()
saveAttachmentToPath =
Action
{ _aDescription = ["save attachment to disk"]
, _aAction =
selectedItemHelper (asMailView . mvAttachments) $ \ent -> do
filePath <- uses (asMailView . mvSaveToDiskPath . E.editContentsL) (T.unpack . currentLine)
runExceptT (writeEntityToPath filePath ent)
>>= either
(\e -> do
assignError e
modifying (asMailView . mvSaveToDiskPath . E.editContentsL) clearZipper )
(\fp -> assignError (GenericError $ "Attachment saved to: " <> fp))
}
chain :: Action v ctx a -> Action v ctx b -> Action v ctx b
chain (Action d1 f1) (Action d2 f2) = Action (d1 <> d2) (f1 *> f2)
chain'
:: forall v v' ctx ctx' a b.
(HasName ctx, HasViewName v, HasName ctx', HasViewName v', ViewTransition v v')
=> Action v ctx a
-> Action v' ctx' b
-> Action v ctx b
chain' (Action d1 f1) (Action d2 f2) =
Action (d1 <> d2) (f1 *> switchMode *> f2)
where
switchMode = do
sink <- use (asConfig . confLogSink)
liftIO . sink . LT.pack $
"chain' "
<> show (viewname (Proxy @v)) <> "/" <> show (name (Proxy @ctx)) <> " -> "
<> show (viewname (Proxy @v')) <> "/" <> show (name (Proxy @ctx'))
modify (transitionHook (Proxy @v) (Proxy @v'))
modifying (asViews . vsFocusedView) (Brick.focusSetCurrent (viewname (Proxy @v')))
assign (asViews . vsViews . at (viewname (Proxy @v')) . _Just . vFocus) (name (Proxy @ctx'))
done :: forall a v. (HasViewName v, Completable a) => Action v a ()
done = Action ["apply"] (complete (Proxy @a))
abort :: forall a v. (HasViewName v, Resetable v a) => Action v a ()
abort = Action ["cancel"] (reset (Proxy @v) (Proxy @a))
focus :: forall v a. (HasViewName v, HasName a, Focusable v a) => Action v a ()
focus = Action
["switch mode to " <> T.pack (show (name (Proxy @a)))] $ do
sink <- use (asConfig . confLogSink)
liftIO . sink . LT.pack $
"switchFocus "
<> show (viewname (Proxy @v)) <> " "
<> show (name (Proxy @a))
switchFocus (Proxy @v) (Proxy @a)
noop :: Action v ctx ()
noop = Action mempty (pure ())
scrollUp :: forall ctx v. (Scrollable ctx) => Action v ctx ()
scrollUp = Action
{ _aDescription = ["scroll up"]
, _aAction = lift (Brick.vScrollBy (makeViewportScroller (Proxy @ctx)) (-1))
}
scrollDown :: forall ctx v. (Scrollable ctx) => Action v ctx ()
scrollDown = Action
{ _aDescription = ["scroll down"]
, _aAction = lift (Brick.vScrollBy (makeViewportScroller (Proxy @ctx)) 1)
}
scrollPageUp :: forall ctx v. (Scrollable ctx) => Action v ctx ()
scrollPageUp = Action
{ _aDescription = ["page up"]
, _aAction = lift (Brick.vScrollPage (makeViewportScroller (Proxy @ctx)) T.Up)
}
scrollPageDown :: forall ctx v. (Scrollable ctx) => Action v ctx ()
scrollPageDown = Action
{ _aDescription = ["page down"]
, _aAction = lift (Brick.vScrollPage (makeViewportScroller (Proxy @ctx)) T.Down)
}
scrollNextWord :: forall ctx v. (Scrollable ctx) => Action v ctx ()
scrollNextWord =
Action
{ _aDescription = ["find next word in mail body"]
, _aAction = do
lift $ Brick.vScrollToBeginning (makeViewportScroller (Proxy @ctx))
b <- gets (has (asMailView . mvScrollSteps))
if b
then do
modifying (asMailView . mvScrollSteps) Brick.focusNext
nextLine <- preuse (asMailView . mvScrollSteps . to Brick.focusGetCurrent . _Just . _1)
let scrollBy = view (non 0) nextLine
lift $ Brick.vScrollBy (makeViewportScroller (Proxy @ctx)) scrollBy
else
assignError (GenericError "No match")
}
removeHighlights :: Action 'ViewMail 'ScrollingMailView ()
removeHighlights =
Action
{ _aDescription = ["remove search results highlights"]
, _aAction = modify resetMatchingWords
}
displayMail :: Action 'ViewMail 'ScrollingMailView ()
displayMail =
Action
{ _aDescription = ["display an e-mail"]
, _aAction = do
lift $ Brick.vScrollToBeginning (makeViewportScroller (Proxy @'ScrollingMailView))
updateStateWithParsedMail
updateReadState RemoveTag
}
displayThreadMails :: Action 'Threads 'ListOfThreads ()
displayThreadMails =
Action
{ _aDescription = ["display an e-mail for threads"]
, _aAction = do
dbpath <- use (asConfig . confNotmuch . nmDatabase)
selectedItemHelper (asMailIndex . miListOfThreads) $ \(_, t) ->
runExceptT (Notmuch.getThreadMessages dbpath (Identity t))
>>= either assignError (\vec -> do
modifying (asMailIndex . miMails . listList) (L.listReplace vec Nothing)
assign (asMailIndex . miMails . listLength) (Just (length vec)) )
}
setUnread :: Action 'ViewMail 'ScrollingMailView ()
setUnread =
Action
{ _aDescription = ["toggle unread"]
, _aAction = updateReadState AddTag
}
listUp
:: forall v ctx. (HasList ctx, Foldable (T ctx), L.Splittable (T ctx))
=> Action v ctx ()
listUp = Action ["list up"] (modifying (list (Proxy @ctx)) L.listMoveUp)
listDown
:: forall v ctx. (HasList ctx, Foldable (T ctx), L.Splittable (T ctx))
=> Action v ctx ()
listDown = Action ["list down"] (modifying (list (Proxy @ctx)) L.listMoveDown)
listJumpToStart
:: forall v ctx. (HasList ctx, Foldable (T ctx), L.Splittable (T ctx))
=> Action v ctx ()
listJumpToStart = Action ["list top"] (modifying (list (Proxy @ctx)) (L.listMoveTo 0))
listJumpToEnd
:: forall v ctx. (HasList ctx, Foldable (T ctx), L.Splittable (T ctx))
=> Action v ctx ()
listJumpToEnd = Action ["list bottom"] (modifying (list (Proxy @ctx)) (L.listMoveTo (-1)))
switchComposeEditor :: Action 'Threads 'ListOfThreads ()
switchComposeEditor =
Action
{ _aDescription = ["switch to compose editor"]
, _aAction = do
l <- use (asCompose . cAttachments)
unless (null l) $
modifying (asViews . vsFocusedView) (Brick.focusSetCurrent ComposeView)
}
encapsulateMail :: Action 'ViewMail 'ScrollingMailView ()
encapsulateMail =
Action
{ _aDescription = ["forward selected e-mail"]
, _aAction = do
mail <- use (asMailView . mvMail)
case mail of
Nothing -> assignError (GenericError "No mail selected for forwarding")
Just m -> do
modifying (asCompose . cAttachments)
(L.listInsert 1 (encapsulate m) . L.listInsert 0 (createTextPlainMessage mempty))
modifying (asCompose . cSubject . E.editContentsL)
(insertMany (getForwardedSubject m) . clearZipper)
}
replyMail :: Action 'ViewMail 'ScrollingMailView ()
replyMail = Action
{ _aDescription = ["reply to an e-mail"]
, _aAction = do
mail <- use (asMailView . mvMail)
case mail of
Nothing -> do
modifying (asViews . vsFocusedView) (Brick.focusSetCurrent Threads)
assignError (GenericError "No mail selected for replying")
Just m -> do
mailboxes <- use (asConfig . confComposeView . cvIdentities)
mbody <- use (asMailView . mvBody)
let quoted = toQuotedMail mailboxes mbody m
modifying (asCompose . cTo . E.editContentsL) (insertMany (getTo quoted) . clearZipper)
modifying (asCompose . cFrom . E.editContentsL) (insertMany (getFrom quoted) . clearZipper)
modifying (asCompose . cSubject . E.editContentsL) (insertMany (getSubject quoted) . clearZipper)
modifying (asCompose . cAttachments) (insertOrReplaceAttachment quoted)
}
toggleHeaders :: Action 'ViewMail 'ScrollingMailView ()
toggleHeaders = Action
{ _aDescription = ["toggle mail headers"]
, _aAction = modifying (asMailView . mvHeadersState) f
}
where
f Filtered = ShowAll
f ShowAll = Filtered
setTags :: forall v ctx. HasToggleableList ctx => [TagOp] -> Action v ctx ()
setTags ops =
Action
{ _aDescription = ["apply tag operations: " <> T.intercalate ", " (T.pack . show <$> ops) ]
, _aAction = do
w <- gets focusedViewWidget
case w of
ScrollingMailView ->
toggledOrSelectedItemHelper
(Proxy @'ScrollingMailView)
(manageMailTags ops)
(over _2 (Notmuch.tagItem ops))
ListOfThreads ->
toggledOrSelectedItemHelper
(Proxy @'ListOfThreads)
(manageThreadTags ops)
(over _2 (Notmuch.tagItem ops))
_ -> error "setTags called on widget without a registered handler"
}
reloadList :: Action 'Threads 'ListOfThreads ()
reloadList = Action ["reload list of threads"] applySearch
selectNextUnread :: Action 'ViewMail 'ListOfMails ()
selectNextUnread = Action
{ _aDescription = ["select next unread"]
, _aAction = do
p <- uses (asConfig . confNotmuch . nmNewTag) Notmuch.hasTag
let f l = maybe (L.listMoveTo (-1) l) (const l) (view L.listSelectedL l)
modifying (asMailIndex . miListOfMails) (f . L.listFindBy (p . view _2))
}
toggleListItem :: forall v ctx. HasToggleableList ctx => Action v ctx ()
toggleListItem =
Action
{ _aDescription = ["toggle selected state of a list item"]
, _aAction = use (list (Proxy @ctx) . L.listSelectedL) >>= traverse_ (toggle (Proxy @ctx))
}
untoggleListItems :: forall v ctx. HasToggleableList ctx => Action v ctx ()
untoggleListItems =
Action
{ _aDescription = ["untoggle all selected list items"]
, _aAction = untoggleAll (Proxy @ctx)
}
delete :: Action 'ComposeView 'ComposeListOfAttachments ()
delete =
Action
{ _aDescription = ["delete entry"]
, _aAction = do
len <- uses (asCompose . cAttachments . L.listElementsL) length
if len < 2
then
assignError (GenericError "You may not remove the only attachment")
else
use (asCompose . cAttachments . L.listSelectedL)
>>= modifying (asCompose . cAttachments) . maybe id L.listRemove
}
parentDirectory :: Action 'FileBrowser 'ListOfFiles ()
parentDirectory = Action ["go to parent directory"] $
uses (asFileBrowser . fbSearchPath . E.editContentsL) (takeDirectory . currentLine) >>= cd
cd :: (MonadState AppState m, MonadIO m) => FilePath -> m ()
cd fp = do
modifying (asFileBrowser . fbSearchPath . E.editContentsL) (insertMany fp . clearZipper)
fp' <- uses (asFileBrowser . fbSearchPath . E.editContentsL) currentLine
runExceptT (listDirectory' fp')
>>= either assignError (modify . updateBrowseFileContents)
enterDirectory :: Action 'FileBrowser 'ListOfFiles ()
enterDirectory =
Action
{ _aDescription = ["enter directory"]
, _aAction =
selectedItemHelper (asFileBrowser . fbEntries) $ \(_, entry) -> do
curLine <- uses (asFileBrowser . fbSearchPath . E.editContentsL) currentLine
case entry of
Directory dir -> cd (curLine </> dir)
_ -> pure ()
}
createAttachments :: Action 'FileBrowser 'ListOfFiles ()
createAttachments = Action ["adds selected files as attachments"] $ do
sel <- uses (asFileBrowser . fbEntries) L.listSelectedElement
when (isFileUnderCursor sel) $
put =<< liftIO . makeAttachmentsFromSelected =<< get
handleConfirm :: Action 'ComposeView 'ConfirmDialog ()
handleConfirm = Action ["handle confirmation"] keepOrDiscardDraft
composeAsNew :: Action 'ViewMail 'ScrollingMailView ()
composeAsNew = Action ["edit mail as new"] $
preuse (asMailIndex . miListOfMails . to L.listSelectedElement . _Just . _2 . _2)
>>= maybe
(assignError (GenericError "No mail selected"))
(\mail -> do
pmail <- use (asMailView . mvMail)
dbpath <- use (asConfig . confNotmuch . nmDatabase)
charsets <- use (asConfig . confCharsets)
runExceptT (Notmuch.mailFilepath mail dbpath >>= Notmuch.unindexFilePath dbpath)
>>= either assignError (const $ assign asCompose (newComposeFromMail charsets pmail))
)
makeAttachmentsFromSelected :: AppState -> IO AppState
makeAttachmentsFromSelected s = do
let toggled = view (_2 . fsEntryName) <$> toListOf (toggledItemsL (Proxy @'ListOfFiles)) s
selected = toListOf (list (Proxy @'ListOfFiles) . to L.listSelectedElement . _Just . _2 . _2 . fsEntryName) s
parts <- traverse (\x -> createAttachmentFromFile (mimeType x) (makeFullPath x)) (toggled `union` selected)
pure $ s & over (asCompose . cAttachments) (listAppendAttachments parts)
. over (asViews . vsFocusedView) (Brick.focusSetCurrent ComposeView)
. set (asViews . vsViews . ix ComposeView . vFocus) ComposeListOfAttachments
where
makeFullPath path = currentLine (view (asFileBrowser . fbSearchPath . E.editContentsL) s) </> path
listAppendAttachments parts = L.listMoveTo (-1) . over L.listElementsL (<> Vector.fromList parts)
isFileUnderCursor :: Maybe (a, (b, FileSystemEntry)) -> Bool
isFileUnderCursor i = maybe False isFile (preview (_Just . _2 . _2) i)
where isFile (File _) = True
isFile _ = False
updateBrowseFileContents :: [FileSystemEntry] -> AppState -> AppState
updateBrowseFileContents contents s =
let contents' = view vector ((False, ) <$> contents)
in over (asFileBrowser . fbEntries) (L.listReplace contents' (Just 0)) s
applySearch :: (MonadIO m, MonadState AppState m) => m ()
applySearch = do
searchterms <- currentLine <$> use (asMailIndex . miSearchThreadsEditor . E.editContentsL)
nmconf <- use (asConfig . confNotmuch)
r <- runExceptT (Notmuch.getThreads searchterms nmconf)
case r of
Left e -> assignError e
Right threads -> do
liftIO (zonedTimeToUTC <$> getZonedTime) >>= assign asLocalTime
notifyNumThreads threads
modifying (asMailIndex . miThreads . listList) (L.listReplace threads (Just 0))
assign (asMailIndex . miThreads . listLength) Nothing
notifyNumThreads :: (MonadState AppState m, MonadIO m, Foldable t) => t a -> m ()
notifyNumThreads l = do
nextGen <- uses (asMailIndex . miListOfThreadsGeneration) nextGeneration
chan <- use (asConfig . confBChan)
void . liftIO . forkIO $
let len = length l
in len `seq` writeBChan chan (NotifyNumThreads len nextGen)
assign (asMailIndex . miListOfThreadsGeneration) nextGen
toggledOrSelectedItemHelper ::
(HasToggleableList n, L.Splittable (T n), MonadState AppState m)
=> Proxy n
-> ([E n] -> m b)
-> (E n -> E n)
-> m ()
toggledOrSelectedItemHelper proxy fx updateFx = do
toggled <- gets (toListOf (toggledItemsL proxy))
selected <-
gets (toListOf (list proxy . to L.listSelectedElement . _Just . to snd))
if null toggled
then fx selected >> modifying (list proxy) (L.listModify updateFx)
else fx toggled >> modifying (toggledItemsL proxy) updateFx
pure ()
selectedItemHelper
:: (Foldable t, L.Splittable t, MonadState AppState m)
=> Getting (L.GenericList n t a) AppState (L.GenericList n t a)
-> (a -> m b)
-> m ()
selectedItemHelper l f = do
item <- use l
case L.listSelectedElement item of
Just (_, a) -> void $ f a
Nothing -> assignError (GenericError "No item selected.")
getEditorTagOps :: HasEditor n => Proxy n -> AppState -> Either Error [TagOp]
getEditorTagOps p s =
let contents = (foldr (<>) "" $ E.getEditContents $ view (editorL p) s)
in parseTagOps contents
applyTagOps
:: (Traversable t, MonadIO m)
=> [TagOp]
-> t (Toggleable NotmuchMail)
-> AppState
-> m (Either Error (t NotmuchMail))
applyTagOps ops mails s =
let dbpath = view (asConfig . confNotmuch . nmDatabase) s
ms = snd <$> mails
in runExceptT (Notmuch.messageTagModify dbpath ops ms)
updateStateWithParsedMail :: (MonadIO m, MonadMask m, MonadState AppState m) => m ()
updateStateWithParsedMail = do
db <- use (asConfig . confNotmuch . nmDatabase)
charsets <- use (asConfig . confCharsets)
textwidth <- use (asConfig . confMailView . mvTextWidth)
preferredContentType <- use (asConfig . confMailView . mvPreferredContentType)
s <- get
selectedItemHelper (asMailIndex . miListOfMails) $ \(_, m) ->
runExceptT (parseMail m db >>= bodyToDisplay s textwidth charsets preferredContentType)
>>= either
(\e -> do
assignError e
modifying (asViews . vsFocusedView) (Brick.focusSetCurrent Threads) )
(\(pmail, mbody) -> do
assign (asMailView . mvMail) (Just pmail)
assign (asMailView . mvBody) mbody
modifying (asViews . vsFocusedView) (Brick.focusSetCurrent ViewMail)
assign (asMailView . mvAttachments) (setEntities pmail) )
where
setEntities m =
L.list MailListOfAttachments (view vector $ toListOf entities m) 0
updateReadState :: (MonadState AppState m, MonadIO m) => (Tag -> TagOp) -> m ()
updateReadState con = do
op <- con <$> use (asConfig . confNotmuch . nmNewTag)
toggledOrSelectedItemHelper
(Proxy @'ScrollingMailView)
(manageMailTags [op])
(over _2 (Notmuch.tagItem [op]))
modifying (asMailIndex . miListOfThreads) (L.listModify (over _2 $ Notmuch.tagItem [op]))
manageMailTags ::
(Traversable t, MonadIO m, MonadState AppState m)
=> [TagOp]
-> t (Toggleable NotmuchMail)
-> m ()
manageMailTags ops ms = do
result <- applyTagOps ops ms =<< get
case result of
Left e -> assignError e
Right _ -> pure ()
setError :: Error -> AppState -> AppState
setError = set asError . Just
assignError :: (MonadState AppState m) => Error -> m ()
assignError = assign asError . Just
sendMail :: (MonadState AppState m, MonadCatch m, MonadIO m) => m ()
sendMail = do
maildir <- use (asConfig . confNotmuch . nmDatabase)
sentTag <- use (asConfig . confNotmuch . nmSentTag)
buildMail $ \bs -> do
trySendAndCatch bs
runExceptT ( do
fp <- createSentFilePath maildir
tryIO $ LB.writeFile fp (B.toLazyByteString bs)
Notmuch.indexFilePath maildir fp [sentTag] )
>>= either assignError (const $ pure ())
buildMail :: (MonadState AppState m, MonadIO m) => (B.Builder -> m ()) -> m ()
buildMail k = do
attachments' <- uses (asCompose . cAttachments . L.listElementsL) toList
mail <- case attachments' of
[x] -> pure (Just x)
x:xs -> do
(boundary, newBoundary) <- uses (asConfig . confBoundary) (splitAt 50)
assign (asConfig . confBoundary) newBoundary
pure . Just $ createMultipartMixedMessage (C8.pack boundary) (x:|xs)
[] -> pure Nothing
case mail of
Nothing -> assignError (GenericError "Black hole detected")
Just m -> do
charsets <- use (asConfig . confCharsets)
now <- liftIO getCurrentTime
to' <- uses (asCompose . cTo)
(either (pure []) id . AT.parseOnly AddressText.addressList . T.unlines . E.getEditContents)
from <- uses (asCompose . cFrom)
(either (pure []) id . AT.parseOnly AddressText.mailboxList . T.unlines . E.getEditContents)
subject <- uses (asCompose . cSubject) (T.unlines . E.getEditContents)
m
& set (headerSubject charsets) (Just subject)
& set (headerFrom charsets) from
& set (headerTo charsets) to'
& set headerDate (Just now)
& sanitizeMail charsets
& buildMessage
& k
trySendAndCatch :: (MonadState AppState m, MonadIO m, MonadCatch m) => B.Builder -> m ()
trySendAndCatch m = do
cmd <- use (asConfig . confComposeView . cvSendMailCmd)
defMailboxes <- use (asConfig . confComposeView . cvIdentities)
(liftIO (cmd m) >>= either assignError pure >> assign asCompose (initialCompose defMailboxes))
`catch` (assignError . SendMailError . (show :: IOException -> String))
sanitizeMail :: CharsetLookup -> MIMEMessage -> MIMEMessage
sanitizeMail charsets =
over (attachments . headers . contentDisposition . traversed . filename charsets) takeFileName
initialCompose :: [Mailbox] -> Compose
initialCompose mailboxes =
Compose
(E.editorText ComposeFrom (Just 1) (AddressText.renderMailboxes mailboxes))
(E.editorText ComposeTo (Just 1) "")
(E.editorText ComposeCc (Just 1) "")
(E.editorText ComposeBcc (Just 1) "")
(E.editorText ComposeSubject (Just 1) "")
T.empty
(L.list ComposeListOfAttachments mempty 1)
initialDraftConfirmDialog
newComposeFromMail :: CharsetLookup -> Maybe MIMEMessage -> Compose
newComposeFromMail charsets m =
let subject =
preview (_Just . headers . at "subject" . _Just . to decodeLenient) m
from = preview (_Just . headers . at "from" . _Just . to decodeLenient) m
to' = preview (_Just . headers . at "to" . _Just . to decodeLenient) m
cc = preview (_Just . headers . at "cc" . _Just . to decodeLenient) m
bcc = preview (_Just . headers . at "bcc" . _Just . to decodeLenient) m
attachments' =
view vector $ toMIMEMessage charsets <$> toListOf (_Just . entities) m
orEmpty = view (non "")
in Compose
(E.editorText ComposeFrom (Just 1) (orEmpty from))
(E.editorText ComposeTo (Just 1) (orEmpty to'))
(E.editorText ComposeCc (Just 1) (orEmpty cc))
(E.editorText ComposeBcc (Just 1) (orEmpty bcc))
(E.editorText ComposeSubject (Just 1) (orEmpty subject))
T.empty
(L.list ComposeListOfAttachments attachments' 1)
initialDraftConfirmDialog
initialDraftConfirmDialog :: Dialog ConfirmDraft
initialDraftConfirmDialog = dialog (Just "Keep draft?") (Just (0, [("Keep", Keep), ("Discard", Discard)])) 50
invokeEditor' ::
(MonadState AppState m, MonadIO m, MonadMask m)
=> (MIMEMessage -> L.List Name MIMEMessage -> L.List Name MIMEMessage)
-> m ()
invokeEditor' listUpdate = do
maildir <- use (asConfig . confNotmuch . nmDatabase)
cmd <- use (asConfig . confEditor)
maybeEntity <- preuse (asCompose . cAttachments . to L.listSelectedElement . _Just . _2 . to getTextPlainPart . _Just)
let
mkEntity :: (MonadError Error m) => m B.ByteString
mkEntity = maybe (pure mempty) entityToBytes maybeEntity
entityCmd = EntityCommand handleExitCodeTempfileContents
(draftFileResoure maildir) (\_ fp -> proc cmd [fp]) tryReadProcessStderr
updatePart = modifying (asCompose . cAttachments) . listUpdate . createTextPlainMessage
runExceptT (mkEntity >>= runEntityCommand . entityCmd)
>>= either assignError updatePart
openCommand' :: (MonadIO m, MonadMask m, MonadState AppState m) => MailcapHandler -> m ()
openCommand' cmd = do
let
mkConfig :: (MonadError Error m, MonadIO m) => WireEntity -> m (EntityCommand m FilePath)
mkConfig =
let con = EntityCommand
handleExitCodeThrow
(tmpfileResource (view mhKeepTemp cmd))
(\_ fp -> toProcessConfigWithTempfile (view mhMakeProcess cmd) fp)
tryReadProcessStderr
in fmap con . entityToBytes
selectedItemHelper (asMailView . mvAttachments) $ \ent ->
runExceptT (mkConfig ent >>= runEntityCommand)
>>= either assignError (const $ pure ())
pipeCommand' :: (MonadIO m, MonadMask m, MonadState AppState m) => FilePath -> m ()
pipeCommand' cmd
| null cmd = assignError (GenericError "Empty command")
| otherwise = do
let
mkConfig :: (MonadError Error m, MonadIO m) => WireEntity -> m (EntityCommand m ())
mkConfig =
let con = EntityCommand
handleExitCodeThrow
emptyResource
(\b _ -> setStdin (byteStringInput $ LB.fromStrict b) (proc cmd []))
tryReadProcessStderr
in fmap con . entityToBytes
selectedItemHelper (asMailView . mvAttachments) $ \ent ->
runExceptT (mkConfig ent >>= runEntityCommand)
>>= either assignError (const $ pure ())
editAttachment :: (MonadState AppState m, MonadIO m, MonadMask m) => m ()
editAttachment = selectedItemHelper (asCompose . cAttachments) $ \m ->
case preview (headers . contentDisposition . folded . dispositionType) m of
Just Inline -> invokeEditor' (L.listModify . const)
_ -> assignError (GenericError "Not implemented. See #182")
insertOrReplaceAttachment ::
MIMEMessage
-> L.List Name MIMEMessage
-> L.List Name MIMEMessage
insertOrReplaceAttachment newPart l =
case L.listSelectedElement l of
Nothing -> L.listInsert 0 newPart l
Just _ ->
L.listModify (const newPart) l
getTextPlainPart :: MIMEMessage -> Maybe WireEntity
getTextPlainPart = firstOf (entities . filtered f)
where
f = matchContentType "text" (Just "plain") . view (headers . contentType)
mimeType :: FilePath -> ContentType
mimeType x = let parsed = parseOnly parseContentType $ defaultMimeLookup (T.pack x)
in either (const contentTypeApplicationOctetStream) id parsed
manageThreadTags ::
(Traversable t, MonadIO m, MonadState AppState m)
=> [TagOp]
-> t (Toggleable NotmuchThread)
-> m ()
manageThreadTags ops ts = do
dbpath <- use (asConfig . confNotmuch . nmDatabase)
(either (const mempty) id <$> runExceptT (Notmuch.getThreadMessages dbpath $ toListOf (traversed . _2) ts))
>>= \ms -> (get >>= applyTagOps ops ms)
>>= either assignError (const $ pure ())
keepOrDiscardDraft :: (MonadMask m, MonadIO m, MonadState AppState m) => m ()
keepOrDiscardDraft = do
r <- use (asCompose . cKeepDraft . to dialogSelection)
case r of
Just Keep -> keepDraft
_ -> assignError (GenericError "Draft discarded")
modify clearMailComposition
keepDraft :: (MonadMask m, MonadState AppState m, MonadIO m) => m ()
keepDraft = buildMail $ \bs -> do
maildir <- use (asConfig . confNotmuch . nmDatabase)
draftTag <- use (asConfig . confNotmuch . nmDraftTag)
runExceptT ( do
fp <- createDraftFilePath maildir
tryIO $ LB.writeFile fp (B.toLazyByteString bs)
Notmuch.indexFilePath maildir fp [draftTag] )
>>= either assignError (const $ assignError (GenericError "Draft saved"))
resetMatchingWords :: AppState -> AppState
resetMatchingWords =
over (asMailView . mvBody) removeMatchingWords
. over (asMailView . mvFindWordEditor . E.editContentsL) clearZipper
. set (asMailView . mvScrollSteps) (Brick.focusRing [])