View.hs

{-
Copyright (C) 2013 John Lenz <lenz@math.uic.edu>

This program 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 <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE RecordWildCards #-}
module Handler.View(
    threadWidget
  , threadHeader
  , getThreadR
  , getMessagePartR
) where

import Import
import Control.Monad (replicateM, unless)
import NotmuchCmd
import Settings
import StaticFiles
import Handler.Tags
import Network.Wai (Response(..))
import Network.HTTP.Types (status200)
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Blaze.ByteString.Builder (fromByteString)
import qualified Data.Map as M
import qualified Data.Tree as TR
import qualified Data.CaseInsensitive as CI

messageContent :: MessageID -> MessagePart -> T.Text -> Widget
messageContent mid m "" = [whamlet|
<div .message-attachment>
  <p>
    <a href="@{MessagePartR mid (partID m)}">
      $case partContentFilename m
          $of Just f
              #{f}
          $of Nothing
              <span>No filename
    (#{partContentType m})
|]
messageContent _ _ txt = [whamlet|
<div .message-text>
  <pre>
    #{txt}
|]

messagePart :: MessageID -> MessagePart -> Widget
messagePart mid m = [whamlet|
<div .message-part>
  $case partContent m
    $of Left x
        ^{messageContent mid m x}
    $of Right ms
        $forall p <- ms
          ^{messagePart mid p}
|]

messageWidget :: Message -> Widget
messageWidget (Message {..}) = [whamlet|
<div .message data-notmuch-message-id="#{unMessageID messageId}">
  <dl .dl-horizontal>
    $forall (h,v) <- M.toList messageHeaders
      <dt>#{CI.original h}
      <dd>#{v}
  $forall part <- messageBody
    ^{messagePart messageId part}
|]

messages :: TR.Forest Message -> Widget
messages [] = return ()
messages forest = do
    ids <- replicateM (length forest) (lift 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 .page-header>
        <h3>#{s}
<div #messageThread data-notmuch-threadid=#{t}>
    ^{messages (threadForest thread)}
|]

-- | The header code for displaying threads, should only be included once in the page
threadHeader :: Widget
threadHeader = do
    tagHeader
    toWidget [julius|
$(document).on("notmuch:retag", "span.tags", function(e, data) {
    if ($.inArray("unread", data.remove) >= 0) {
        $(this).parents("div.accordion-group").children("div.accordion-body").each(function(idx, b) {
            $(b).collapse('hide');
        });
    }
});
|]

getThreadR :: ThreadID -> Handler RepHtml
getThreadR t = defaultLayout $ do
    pjax <- lift isPjax
    unless pjax threadHeader
    threadWidget t

getMessagePartR :: MessageID -> Int -> Handler ()
getMessagePartR mid part = do
    let (getMsg, rawMsg) = notmuchMessagePart mid part
    msg <- getMsg

    let contentdisp = case partContentFilename msg of
                        Just f  -> [("Content-Disposition", "attachment;filename=\"" <> T.encodeUtf8 f <> "\"")]
                        Nothing -> []
    let contenttype = [("Content-Type", T.encodeUtf8 $ partContentType msg)]

    let source = rawMsg $= CL.map (Chunk . fromByteString)

    sendWaiResponse $ ResponseSource status200 (contentdisp ++ contenttype) source