module Handler.View(
threadWidget
, threadHeader
, getThreadR
, getMessagePartR
) where
import Import
import FilterHtml
import StaticFiles
import Handler.Tags
import Blaze.ByteString.Builder (fromByteString)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Markdown
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C
import qualified Data.Conduit.Text as C
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Tree as TR
#ifdef USE_ICU
import qualified Data.Text.ICU.Convert as ICU
#endif
decodePart :: (MonadLogger m, MonadHandler m)
=> Maybe (CI.CI T.Text) -> Source (ResourceT IO) B.ByteString -> m TL.Text
decodePart charset src = case charset of
Just "ISO-8859-1" -> decodeConduit C.iso8859_1
Just "UTF-8" -> decodeConduit C.utf8
#ifdef USE_ICU
Just x -> decodeICU $ CI.original x
#endif
_ -> decodeConduit C.utf8
where decodeConduit c = TL.fromChunks <$> liftResourceT (src $= C.decode c $$ C.consume)
#ifdef USE_ICU
decodeICU x = do $(logInfo) ("Decoding using ICU: " `T.append` x)
raw <- liftResourceT (src $$ C.consume)
c <- liftIO $ ICU.open (T.unpack x) (Just True)
return $ TL.fromStrict $ ICU.toUnicode c $ B.concat raw
#endif
messagePart :: MessageID -> Bool -> MessagePart -> Widget
messagePart mid _ p@(MessagePart {partContentType = "text/html"}) = do
let ((_ :: IO MessagePart), src) = notmuchMessagePart mid $ partID p
html <- TL.toStrict <$> decodePart (partContentCharset p) src
[whamlet|
<div .messagepart .messagehtml>
#{preEscapedToMarkup $ filterHtml html}
|]
messagePart mid _ m@(MessagePart {partContent = ContentText ""}) = [whamlet|
<div .messagepart .messageattachment>
<p>
<a href="@{MessagePartR mid (partID m)}">
$case partContentFilename m
$of Just f
#{f}
$of Nothing
<span>No filename
(#{CI.original $ partContentType m})
|]
messagePart _ True (MessagePart {partContent = ContentText txt}) = [whamlet|
<div .messagepart .messagetext>
<pre>
#{txt}
|]
messagePart _ False (MessagePart {partContent = ContentText txt}) = do
let html = TL.toStrict $ renderHtml $ markdown markdownSettings $ TL.fromStrict txt
htmlId <- newIdent
txtId <- newIdent
[whamlet|
<div .messagepart .messagemarkdown>
<ul .nav .navtabs>
<li .textasmarkdown>
<a datatoggle=tab datatarget="##{htmlId}">Markdown
<li .active>
<a datatoggle=tab datatarget="##{txtId}">Text
<div .tabcontent>
<div .tabpane ##{htmlId}>
#{preEscapedToMarkup $ filterHtml html}
<div .tabpane .active ##{txtId}>
<pre>
#{txt}
|]
messagePart _ _ (MessagePart {partContent = ContentMultipart []}) = return ()
messagePart mid _ (MessagePart {partContentType = "multipart/alternative", partContent = ContentMultipart (alternatives@(a:_))}) = do
let active = maybe a id $ find (\x -> partContentType x == "text/html") alternatives
isActive p = partID active == partID p
ids <- mapM (const newIdent) alternatives
[whamlet|
<div .messagepart .messagealternative>
<ul .nav .navtabs>
$forall (i,p) <- zip ids alternatives
<li :isActive p:.active>
<a datatoggle=tab datatarget="##{i}">#{CI.original $ partContentType p}
<div .tabcontent>
$forall (i,p) <- zip ids alternatives
<div .tabpane :isActive p:.active ##{i}>
^{messagePart mid True p}
|]
messagePart mid _ (MessagePart {partContent = ContentMultipart parts}) =
[whamlet|
<div .messagepart .messagemultipart>
$forall p <- parts
^{messagePart mid False p}
|]
messagePart mid _ (MessagePart {partContent = ContentMsgRFC822 lst}) =
[whamlet|
<div .messagepart .messagerfc822>
$forall (headers,parts) <- lst
<div .messagerfc822entry>
<dl .dlhorizontal>
$forall (h,v) <- M.toList headers
<dt>#{CI.original h}
<dd>#{v}
$forall part <- parts
^{messagePart mid False part}
|]
messageWidget :: Message -> Widget
messageWidget (Message {..}) = [whamlet|
<div .message datanotmuchmessageid="#{unMessageID messageId}">
<dl .dlhorizontal>
$forall (h,v) <- M.toList messageHeaders
<dt>#{CI.original h}
<dd>#{v}
$forall part <- messageBody
^{messagePart messageId False part}
|]
messages :: TR.Forest Message -> Widget
messages [] = return ()
messages forest = do
ids <- replicateM (length forest) newIdent
let forestWithIds = zip forest ids
let isUnread m = "unread" `elem` messageTags m
$(widgetFile "thread")
threadWidget :: ThreadID -> Widget
threadWidget t = do
thread <- notmuchShow t
let msubject = case thread of
(Thread ((TR.Node m _):_)) -> Just $ messageSubject m
_ -> Nothing
case msubject of
Just s -> setTitle $ toHtml s
Nothing -> return ()
[whamlet|
$maybe s <- msubject
<div .pageheader>
<h3>#{s}
<div #messageThread datanotmuchthreadid=#{t}>
^{messages (threadForest thread)}
|]
threadHeader :: Widget
threadHeader = do
tagHeader
$(widgetFile "thread-header")
getThreadR :: ThreadID -> Handler Html
getThreadR t = defaultLayout $ do
pjax <- isPjax
unless pjax threadHeader
threadWidget t
getMessagePartR :: MessageID -> Int -> Handler TypedContent
getMessagePartR mid part = do
let (getMsg, rawMsg) = notmuchMessagePart mid part
msg <- getMsg
case partContentFilename msg of
Just f ->
addHeader "Content-Disposition"
("attachment;filename=\"" <> f <> "\"")
Nothing -> return ()
let contenttype = T.encodeUtf8 $ CI.original $ partContentType msg
let source = rawMsg $= C.map (Chunk . fromByteString)
respondSource contenttype source
markdownSettings :: MarkdownSettings
markdownSettings = def { msLinkNewTab = True
, msXssProtect = False
, msBlankBeforeBlockquote = False
}