{-# LANGUAGE OverloadedStrings #-}
module UI.Mail.Main
( renderMailView
, renderAttachmentsList
, renderPart
, buildWordMarkup
) where
import qualified Brick.AttrMap as A
import Brick.Types (Padding(..), ViewportType(..), Widget)
import qualified Brick.Widgets.List as L
import Brick.Widgets.Core
(padTop, padBottom, txt, txtWrap, viewport, (<+>), (<=>), withAttr,
vBox, hBox, padLeftRight, padRight)
import Brick.Markup (markup, (@?))
import Brick.Focus (focusGetCurrent)
import Data.Text.Markup (Markup, markupSet)
import Control.Lens
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
import Prelude hiding (Word)
import Data.MIME
import Types
import UI.Draw.Main (attachmentsHeader)
import UI.Views (focusedViewWidget)
import Config.Main
(headerKeyAttr, headerValueAttr, mailViewAttr, listSelectedAttr,
listAttr, textMatchHighlightAttr, currentTextMatchHighlightAttr,
defaultAttr, mailbodySourceAttr)
import Storage.ParsedMail (takeFileName)
renderMailView :: AppState -> Widget Name
renderMailView s = viewport ScrollingMailView Vertical (mailView s (view (asMailView . mvMail) s))
mailView :: AppState -> Maybe MIMEMessage -> Widget Name
mailView s (Just msg) = withAttr mailViewAttr $ messageToMailView s msg
mailView _ Nothing = txt "Eeek: this is not supposed to happen"
messageToMailView :: AppState -> MIMEMessage -> Widget Name
messageToMailView s msg =
let
body' = renderMarkup
(preview (asMailView . mvScrollSteps . to focusGetCurrent . _Just) s)
(view (asMailView . mvBody) s)
wantHeader :: CI.CI B.ByteString -> Bool
wantHeader = case view (asMailView . mvHeadersState) s of
Filtered -> view (asConfig . confMailView . mvHeadersToShow) s
ShowAll -> const True
filteredHeaders =
toListOf (headerList . folded . filtered (wantHeader . fst)) msg
headerToWidget :: (CI.CI B.ByteString, B.ByteString) -> Widget Name
headerToWidget (k, v) =
withAttr headerKeyAttr $
txt (decodeLenient (CI.original k) <> ": ")
<+> withAttr headerValueAttr (txtWrap (decodeEncodedWords charsets v))
headerWidgets = headerToWidget <$> filteredHeaders
bodyWidget = padTop (Pad 1) body'
charsets = view (asConfig . confCharsets) s
in
vBox headerWidgets <=> padTop (Pad 1) bodyWidget
renderAttachmentsList :: AppState -> Widget Name
renderAttachmentsList s =
let hasFocus = MailListOfAttachments == focusedViewWidget s
attachmentsList =
L.renderList (\isSel -> renderPart charsets isSel . view headers) hasFocus (view (asMailView . mvAttachments) s)
charsets = view (asConfig . confCharsets) s
in attachmentsHeader <=> attachmentsList
renderPart :: CharsetLookup -> Bool -> Headers -> Widget Name
renderPart charsets selected hds =
let pType = showContentType $ view contentType hds
pFilename = maybe "--" takeFileName $
preview (contentDisposition . folded . filename charsets) hds
listItemAttr = if selected then listSelectedAttr else listAttr
attachmentType = txt (if isAttachment hds then "A" else "I")
widget = hBox
[ padLeftRight 1 attachmentType
, padRight Max (txt pFilename)
, txt pType
]
in withAttr listItemAttr widget
renderMarkup :: Maybe ScrollStep -> MailBody -> Widget Name
renderMarkup st b =
let source =
withAttr mailbodySourceAttr $
padBottom (Pad 1) $ txt ("Showing output from: " <> view mbSource b)
bodyMarkup = toListOf (mbParagraph . to (padBottom (Pad 1) . buildParagraph st)) b
in source <=> vBox bodyMarkup
buildParagraph :: Maybe ScrollStep -> Paragraph -> Widget Name
buildParagraph st = vBox . toListOf (pLine . to (markup . buildWordMarkup st))
buildWordMarkup :: Maybe ScrollStep -> Line -> Markup A.AttrName
buildWordMarkup st (Line xs _ t) = foldr (go st) (t @? defaultAttr) xs
where
go :: Maybe ScrollStep -> Match -> Markup A.AttrName -> Markup A.AttrName
go Nothing (Match offset l _) m =
markupSet (offset, l) textMatchHighlightAttr m
go (Just step) ma@(Match offset l _) m =
if view stMatch step == ma
then markupSet (offset, l) currentTextMatchHighlightAttr m
else markupSet (offset, l) textMatchHighlightAttr m