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
emailInBrackets :: Parser T.Text
emailInBrackets = do
void $ char '<'
y <- takeTill (=='>') <?> "Email address"
void (char '>' <?> "Expecting '>'")
skipSpace
return y
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
addresses :: Parser [Address]
addresses = do as <- sepBy address (char ',')
endOfInput <?> "Expecting ',' or '>'"
return as
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.encodeUtf8 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 (HandlerT App IO) [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 (HandlerT App IO) [(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 (HandlerT master IO) [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 = ContentText t}):_) = Just t
findBodyText ((MessagePart {NotmuchCmd.partContent = ContentMsgRFC822 _}):_) = Nothing
findBodyText ((MessagePart {NotmuchCmd.partContent = ContentMultipart 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
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) -> liftResourceT $ 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 .controlgroup .span10>
<label .controllabel for=#{fvId v}>#{fvLabel v}
<div .controls>
^{fvInput v}
<div .controlgroup>
^{fvInput bView}
<div .controlgroup>
<label .controllabel for=#{fvId attachView}>#{fvLabel attachView}
<div .controls>
^{fvInput attachView}
|]
return (mail, widget)
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")
messageID :: Handler T.Text
messageID = do t <- liftIO getCurrentTime
let ts = formatTime defaultTimeLocale "%s" t
i <- abs <$> liftIO (randomIO :: IO Int)
domain <- extraMessageIDDomain <$> getExtra
case domain of
"" -> return ""
_ -> return $ T.concat ["<notmuch-web-", T.pack ts, ".", T.pack (show i), "@", domain, ">"]
postComposeR :: Handler RepHtml
postComposeR = do
from <- fromAddress
((result,widget),enctype) <- runFormPost $ composeForm from Nothing
case result of
FormSuccess m -> do
mid <- messageID
msg <- liftIO $ renderMail' $ m {mailHeaders = mailHeaders m ++ [("Message-ID", mid)]}
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")