Compose.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/>.
-}
module Handler.Compose (getComposeR, postComposeR, getReplyR, getReplyAllR) where

import Import
import Settings
import Network.Mail.Mime
import Data.Time
import System.Locale
import System.Random (randomIO)
import System.FilePath ((</>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Text.Email.Validate as E
import qualified Data.Map as M
import qualified Data.CaseInsensitive as CI
import Data.Attoparsec.Text
import Data.String (fromString)
import NotmuchCmd

-- | Parse an email address in angle brackets
emailInBrackets :: Parser T.Text
emailInBrackets = do
    void $ char '<'
    y <- takeTill (=='>') <?> "Email address"
    void (char '>' <?> "Expecting '>'")
    skipSpace
    return y

-- | Parses an email address, which can either just be a direct email
-- address or can be an address in the form "Name <email>"
address :: Parser Address
address = do
    x <- T.strip <$> takeTill (\c -> c == '<' || c == ',')
    y <- Just <$> emailInBrackets <|> return Nothing
    case y of
        Just e -> return $ Address (Just x) e
        Nothing -> return $ Address Nothing x

-- | Parse a list of addresses seperated by commas
addresses :: Parser [Address]
addresses = do as <- sepBy address (char ',')
               endOfInput <?> "Expecting ',' or '>'"
               return as

-- | A version of parseOnly which includes the context of the failure.
parseOnly' :: Parser a -> T.Text -> Either String a
parseOnly' p t = checkRes (parse p t)
    where checkRes result = case result of
                              Fail _ ctx err -> Left $ show ctx ++ " " ++ err
                              Partial f -> checkRes $ f ""
                              Done _ x -> Right $ x

parseAddresses :: T.Text -> Either (SomeMessage App) (Maybe [Address])
parseAddresses t = case parseOnly' addresses t of
                       Left err -> Left $ fromString err
                       Right [] -> Right $ Nothing
                       Right addrs -> Just <$> mapM checkAddr addrs
    where
        checkAddr a@(Address _ e) | E.isValid (T.unpack e) = Right a
        checkAddr (Address _ e)   | otherwise = Left $ SomeMessage $ MsgInvalidEmail e

showAddresses :: [Address] -> T.Text
showAddresses as = T.intercalate ", " $ map showA as
    where showA (Address {addressName = Just name, addressEmail = e}) = T.concat [name, " <", e, ">"]
          showA (Address {addressName = Nothing, addressEmail = e}) = e

addressField :: Field s App [Address]
addressField = Field { fieldParse = \x _ -> case x of
                                                [] -> return $ Right Nothing
                                                ("":_) -> return $ Right Nothing
                                                (n:_) -> return $ parseAddresses n
                     , fieldView = \theId name attrs val isReq -> [whamlet|
<input id=#{theId} name=#{name} *{attrs} type=text :isReq:required value=#{either id showAddresses val}>
|]
                     , fieldEnctype = UrlEncoded
                     }

header :: Parser (B.ByteString, T.Text)
header = do
    k <- takeWhile1 (\c -> not (isEndOfLine c) && c /= ':')
    void $ char ':'
    skipSpace
    v <- takeTill isEndOfLine
    return (T.encodeUtf8 k, v)

headers :: Parser [(B.ByteString, T.Text)]
headers = sepBy header endOfLine <?> "Headers"

parseHeaders :: T.Text -> Either (SomeMessage App) (Maybe [(B.ByteString,T.Text)])
parseHeaders t = case parseOnly' headers t of
                     Left err -> Left $ fromString err
                     Right [] -> Right $ Nothing
                     Right h -> Right $ Just h

showHeaders :: [(B.ByteString, T.Text)] -> T.Text
showHeaders hs = T.intercalate "\n" $ map showH hs
    where showH (x,y) = T.concat [T.decodeUtf8 x, ": ", y]

headerField :: Field s App [(B.ByteString,T.Text)]
headerField = Field { fieldParse = \x _ -> case x of
                                                [] -> return $ Right Nothing
                                                ("":_) -> return $ Right Nothing
                                                (n:_) -> return $ parseHeaders n
                     , fieldView = \theId name attrs val isReq -> [whamlet|
<textarea id=#{theId} name=#{name} *{attrs} rows=4 cols=50 wrap=off :isReq:required>
    #{either id showHeaders val}
|]
                     , fieldEnctype = UrlEncoded
                     }

multiFile :: Field sub master [FileInfo]
multiFile = Field p view Multipart
    where
        p _ fs = return $ Right $ Just fs
        view fId name attrs _ _ = [whamlet|
<input type=file name=#{name} ##{fId} multiple *{attrs}>
|]

findBodyText :: [MessagePart] -> Maybe T.Text
findBodyText [] = Nothing
findBodyText ((MessagePart {NotmuchCmd.partContent = Left t}):_) = Just t
findBodyText ((MessagePart {NotmuchCmd.partContent = Right sub}):ms) =
    case findBodyText sub of
        Nothing -> findBodyText ms
        Just x -> Just x

replyBody :: Reply -> T.Text
replyBody (Reply {replyOriginal = m})  = T.concat [onmsg, "\n", bdy]
  where
    origfrom = maybe "" id $ M.lookup "from" $ messageHeaders m
    onmsg = T.concat ["On ", T.pack (show $ messageTime m), ", ", origfrom, " wrote: "]
    origlines = T.lines $ maybe "" id $ findBodyText $ messageBody m
    addquote = map (T.append "> ") origlines
    bdy = T.unlines addquote

fileToAttach :: FileInfo -> ResourceT IO Alternatives
fileToAttach f = do
    content <- fileSource f $$ CL.consume
    return [Part (fileContentType f) Base64 (Just $ fileName f) [] (BL.fromChunks content)]

composeForm :: Address -> Maybe Reply -> Form Mail
composeForm from mreply fmsg = do
    let mheaders = replyHeaders <$> mreply
        mto = M.lookup "to" =<< mheaders
        mtoaddr = either (const Nothing) id . parseAddresses =<< mto
        mcc = M.lookup "cc" =<< mheaders
        mccaddr = either (const Nothing) Just . parseAddresses =<< mcc
        --from = maybe (Just f) $ M.lookup "from" =<< extraheaders
        msubj = M.lookup "subject" =<< mheaders
        mbody = Textarea . replyBody <$> mreply
        mextramap = M.delete "to" . M.delete "cc" . M.delete "subject" . M.delete "from" <$> mheaders
        mextra = (\hs -> Just [ (T.encodeUtf8 $ CI.original k, v) | (k,v) <- M.toList hs ]) <$> mextramap

    (to,toView) <- mreq addressField (FieldSettings "To" Nothing (Just "to") Nothing []) mtoaddr
    (cc,ccView) <- mopt addressField (FieldSettings "CC" Nothing (Just "cc") Nothing []) mccaddr
    (bcc,bccView) <- mopt addressField (FieldSettings "BCC" Nothing (Just "bcc") Nothing []) Nothing
    (subject,sView) <- mreq textField (FieldSettings (SomeMessage MsgSubject) Nothing (Just "subject") Nothing []) msubj
    (head,hView) <- mopt headerField (FieldSettings (SomeMessage MsgExtraHeader) Nothing (Just "extraheaders") Nothing []) mextra
    (body,bView) <- mreq textareaField (FieldSettings "Body" Nothing (Just "body") Nothing []) mbody
    (attach,attachView) <- mopt multiFile (FieldSettings (SomeMessage MsgAttach) Nothing (Just "attach") Nothing []) Nothing

    attachParts <- case attach of
                       FormSuccess (Just xs) -> lift $ lift $ mapM fileToAttach xs
                       _ -> return []

    let mkParts b = [[Part "text/plain" QuotedPrintableText Nothing [] $ BL.fromChunks [T.encodeUtf8 $ unTextarea b]]] ++ attachParts
        mkHeaders s e = ("Subject", s) : maybe [] id e
        mail = Mail <$> pure from
                    <*> to
                    <*> (maybe [] id <$> cc)
                    <*> (maybe [] id <$> bcc)
                    <*> (mkHeaders <$> subject <*> head)
                    <*> (mkParts <$> body)

        widget = [whamlet|
 #{fmsg}
 $forall v <- [toView, ccView, bccView, sView, hView]
    <div .control-group .span10>
        <label .control-label for=#{fvId v}>#{fvLabel v}
        <div .controls>
            ^{fvInput v}
 <div .control-group>
    ^{fvInput bView}
 <div .control-group>
    <label .control-label for=#{fvId attachView}>#{fvLabel attachView}
    <div .controls>
        ^{fvInput attachView}
|]
    return (mail, widget)

-- | Lookup the configured from address
fromAddress :: Handler Address
fromAddress = do
    from <- extraFromAddress <$> getExtra
    case parseAddresses from of
        Left err -> invalidArgsI [err]
        Right (Just [x]) -> return x
        Right _ -> invalidArgs ["From address is invalid"]

getComposeR :: Handler RepHtml
getComposeR = do
    from <- fromAddress
    ((_,widget),enctype) <- runFormPost $ composeForm from Nothing
    defaultLayout $ do
        setTitleI MsgCompose
        let err = [] :: [String]
        $(widgetFile "compose")

replyHandler :: ReplyTo -> MessageID -> Handler RepHtml
replyHandler rto m = do
    from <- fromAddress
    reply <- notmuchReply m rto
    ((_,widget),enctype) <- runFormPost $ composeForm from $ Just reply
    defaultLayout $ do
        setTitleI MsgCompose
        let err = [] :: [String]
        $(widgetFile "compose")

getReplyR :: MessageID -> Handler RepHtml
getReplyR = replyHandler ReplySender

getReplyAllR :: MessageID -> Handler RepHtml
getReplyAllR = replyHandler ReplyAll

filenameAndDate :: IO (FilePath, TL.Text)
filenameAndDate = do t <- getCurrentTime >>= utcToLocalZonedTime
                     let ts = formatTime defaultTimeLocale "%F-%T%z" t
                     let ds = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" t
                     i <- randomIO :: IO Int
                     return (ts ++ "-" ++ show i, "Date: " <> TL.pack ds <> "\n")

postComposeR :: Handler RepHtml
postComposeR = do
    from <- fromAddress
    ((result,widget),enctype) <- runFormPost $ composeForm from Nothing
    case result of
        FormSuccess m -> do
            msg <- liftIO $ renderMail' m
            let tmsg = TL.decodeUtf8 msg

            when production $ do
                setMessageI MsgSent
                liftIO $ sendmail msg

            msentbox <- extraSentBox <$> getExtra
            case msentbox of
                Just b -> do (file, dheader) <- liftIO filenameAndDate
                             liftIO $ TL.writeFile (b </> file) $ dheader <> tmsg
                Nothing -> return ()

            defaultLayout [whamlet|<pre>#{tmsg}|]

        FormMissing -> invalidArgs ["Form is missing"]
        FormFailure err -> defaultLayout $ do
            setTitleI MsgCompose
            $(widgetFile "compose")