-- This file is part of purebred -- Copyright (C) 2017-2019 RĂ³man Joost and Fraser Tweedale -- -- purebred is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Purebred.UI.Mail.Main ( renderMailView , renderAttachmentsList , renderPart , buildWordMarkup ) where import qualified Brick.AttrMap as A import Brick.Types (ViewportType(..), Widget) import qualified Brick.Widgets.List as L import Brick.Widgets.Core (Padding(..), padTop, padBottom, txt, txtWrap, viewport, (<+>), (<=>), withAttr, vBox, hBox, padLeftRight, padRight) 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 Purebred.Brick.Markup (markup, (@?)) import Purebred.Types import Purebred.UI.Draw.Main (attachmentsHeader) import Purebred.UI.Views (focusedViewWidget) import Purebred.Config (headerKeyAttr, headerValueAttr, mailViewAttr, listSelectedAttr, listAttr, textMatchHighlightAttr, currentTextMatchHighlightAttr, defaultAttr, mailbodySourceAttr) import Purebred.Storage.Mail (takeFileName) -- | Instead of using the entire rendering area to show the email, we still show -- the index in context above the mail. -- -- Implementation detail: Currently we're creating the sub list of mails we show -- for each key press. This might have to change in the future. 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 -- | render the Mailbody AST to a list used for Markup in Brick -- 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)) -- | Render the line by inserting markup if we have a match *and* a -- scroll step matching -- Note: Why are we ignoring the line number here? Because it only -- matters for scrolling, not for highlighting the match. -- 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