{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Storage.ParsedMail (
parseMail
, bodyToDisplay
, findMatchingWords
, removeMatchingWords
, makeScrollSteps
, getTo
, getSubject
, getForwardedSubject
, getFrom
, toQuotedMail
, takeFileName
, toMIMEMessage
, chooseEntity
, entityToText
, entityToBytes
, writeEntityToPath
) where
import Control.Applicative ((<|>))
import Control.Exception (try)
import Control.Lens
import Data.Text.Lens (packed)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Catch (MonadMask)
import Data.Foldable (toList)
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified System.FilePath as FP (takeFileName)
import Prelude hiding (Word)
import Data.MIME
import Error
import Storage.Notmuch (mailFilepath)
import Types
import Purebred.System (tryIO)
import Purebred.Types.IFC (sanitiseText)
import Purebred.Parsing.Text (parseMailbody)
import Purebred.System.Process
(runEntityCommand, tmpfileResource, toProcessConfigWithTempfile,
tryReadProcessStdout, handleExitCodeThrow)
parseMail
:: (MonadError Error m, MonadIO m)
=> NotmuchMail -> FilePath -> m MIMEMessage
parseMail m dbpath = do
filePath <- mailFilepath m dbpath
liftIO (try (B.readFile filePath))
>>= either (throwError . FileReadError filePath) pure
>>= either (throwError . FileParseError filePath) pure
. parse (message mime)
getHeader :: CI.CI B.ByteString -> Message s a -> T.Text
getHeader k =
maybe "header not found" decodeLenient
. firstOf (headers . header k)
getFrom :: Message s a -> T.Text
getFrom = getHeader "from"
getSubject :: Message s a -> T.Text
getSubject = getHeader "subject"
getTo :: Message s a -> T.Text
getTo = getHeader "to"
getForwardedSubject ::
Message s a
-> T.Text
getForwardedSubject m = "[" <> getFrom m <> ": " <> getSubject m <> "]"
makeScrollSteps :: MailBody -> [ScrollStep]
makeScrollSteps = mkScrollStep <$> itoListOf (indexing (mbParagraph . pLine . lMatches . traversed))
where
mkScrollStep :: [(Int, Match)] -> [ScrollStep]
mkScrollStep = fmap (\(n, m) -> (n + 1, view mLinenumber m, m))
findMatchingWords :: T.Text -> MailBody -> MailBody
findMatchingWords needle =
over (mbParagraph . pLine) go
where
go :: Line -> Line
go line =
let lengthNeedle = T.length needle
lineNumber = view lNumber line
allMatches =
(\(h, _) -> Match (T.length h) lengthNeedle lineNumber) <$>
T.breakOnAll needle (view lText line)
in set lMatches allMatches line
removeMatchingWords :: MailBody -> MailBody
removeMatchingWords =
set (mbParagraph . pLine . filtered hasMatches . lMatches) []
bodyToDisplay ::
(MonadMask m, MonadError Error m, MonadIO m)
=> AppState
-> Int
-> CharsetLookup
-> ContentType
-> MIMEMessage
-> m (MIMEMessage, MailBody)
bodyToDisplay s textwidth charsets prefCT msg =
case chooseEntity prefCT msg of
Nothing ->
throwError
(GenericError $ "Unable to find preferred entity with: " <> show prefCT)
Just entity ->
let output =
maybe
(pure $ parseMailbody textwidth "Internal Viewer" $ entityToText charsets entity)
(\handler ->
parseMailbody textwidth (showHandler handler) <$>
entityPiped handler entity)
(findAutoview s entity)
showHandler = view (mhMakeProcess . mpCommand . to (T.pack . toList))
in (msg, ) <$> output
findAutoview :: AppState -> WireEntity -> Maybe MailcapHandler
findAutoview s msg =
let match ct = firstOf (asConfig . confMailView . mvMailcap . hasCopiousoutput . filtered (`fst` ct) . _2) s
in match =<< preview (headers . contentType) msg
chooseEntity :: ContentType -> MIMEMessage -> Maybe WireEntity
chooseEntity preferredContentType msg =
let
match x = matchContentType
(view (headers . contentType . ctType) x)
(preview (headers . contentType . ctSubtype) x)
preferredContentType
in firstOf (entities . filtered match) msg <|> firstOf entities msg
entityToBytes :: (MonadError Error m) => WireEntity -> m B.ByteString
entityToBytes msg = either err pure (convert msg)
where
err e = throwError $ GenericError ("Decoding error: " <> show e)
convert :: WireEntity -> Either EncodingError B.ByteString
convert m = view body <$> view transferDecoded m
entityToText :: CharsetLookup -> WireEntity -> T.Text
entityToText charsets msg = sanitiseText . either err (view body) $
view transferDecoded msg >>= view (charsetDecoded charsets)
where
err :: EncodingError -> T.Text
err e =
"ERROR: " <> view (to show . packed) e <> ". Showing raw body.\n\n"
<> decodeLenient (view body msg)
entityPiped ::
(MonadMask m, MonadError Error m, MonadIO m)
=> MailcapHandler
-> WireEntity
-> m T.Text
entityPiped handler msg =
entityToBytes msg >>= mkConfig handler >>= runEntityCommand
mkConfig ::
(MonadError Error m, MonadIO m)
=> MailcapHandler
-> B.ByteString
-> m (EntityCommand m FilePath)
mkConfig cmd =
pure .
EntityCommand
handleExitCodeThrow
(tmpfileResource (view mhKeepTemp cmd))
(\_ fp -> toProcessConfigWithTempfile (view mhMakeProcess cmd) fp)
tryReadProcessStdout
quoteText :: T.Text -> T.Text
quoteText = ("> " <>)
toQuotedMail
:: [Mailbox]
-> MailBody
-> MIMEMessage
-> MIMEMessage
toQuotedMail mailboxes mbody msg =
let contents = T.unlines $ toListOf (mbParagraph . pLine . lText . to quoteText) mbody
replyToAddress m =
firstOf (headers . header "reply-to") m
<|> firstOf (headers . header "from") m
in createTextPlainMessage contents
& set (headers . at "from") (Just $ renderMailboxes mailboxes)
. set (headers . at "to") (replyToAddress msg)
. set (headers . at "references") (view (headers . replyHeaderReferences) msg)
. set (headers . at "subject") (("Re: " <>) <$> view (headers . at "subject") msg)
toMIMEMessage :: CharsetLookup -> WireEntity -> MIMEMessage
toMIMEMessage charsets m@(Message _ bs) =
let ct = view (headers . contentType) m
fp = preview (headers . contentDisposition . folded . filename charsets . to T.unpack) m
cdType = preview (headers . contentDisposition . folded . dispositionType) m
in case cdType of
(Just Inline) -> createTextPlainMessage (entityToText charsets m)
_ -> createAttachment ct fp bs
takeFileName :: T.Text -> T.Text
takeFileName = T.pack . FP.takeFileName . T.unpack
writeEntityToPath ::
(MonadError Error m, MonadIO m) => FilePath -> WireEntity -> m FilePath
writeEntityToPath filepath entity = do
entityToBytes entity >>= tryIO . B.writeFile filepath
pure filepath