Commits

John Lenz committed 7427861

General cleanup of compose form

  • Participants
  • Parent commits f48b129

Comments (0)

Files changed (5)

File notmuch-web.cabal

                      Handler.View
                      Handler.Pager
                      Handler.Raw
+                     Handler.ComposeFields
                      Handler.Compose
 
     if flag(dev) || flag(library-only)

File src/Handler/Compose.hs

 module Handler.Compose (getComposeR, postComposeR, getReplyR, getReplyAllR) where
 
 import Import
+import Handler.ComposeFields
 
-import Data.Attoparsec.Text
 import Data.String (fromString)
 import Data.Time
 import Network.Mail.Mime hiding (partContent)
 import System.Locale
 import System.Random (randomIO)
 
-import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as CL
 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
+
+-----------------------------------------------------------------------------------------
+-- Compose Form
+-----------------------------------------------------------------------------------------
 
 instance Eq Address where
     (Address a1 a2) == (Address b1 b2) = a1 == b1 && a2 == b2
 
--- | 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
+-- | Lookup From addresses in the settings
+fromAddresses :: (MonadHandler m, HandlerSite m ~ App) => m (OptionList Address)
+fromAddresses = mkOptionList <$> do
+    addrs <- extraFromAddresses <$> getExtra
+    forM addrs $ \a ->
+        case parseAddress a of
+            Left err -> do
+                setMessageI err
+                return $ Option ("Invalid " <> a) (Address Nothing "") ""
+            Right a' -> return $ Option a a' a
 
--- | 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 an address header like To: and CC: into a list of address
+parseAddrHeader :: (MonadHandler m, HandlerSite m ~ App) => CI.CI T.Text -> Reply -> m [Address]
+parseAddrHeader hdr reply = 
+    case M.lookup hdr (replyHeaders reply) of
+        Nothing -> return []
+        Just x  -> case parseAddresses x of
+                           Left err -> do setMessageI err
+                                          return []
+                           Right addr -> return addr
 
--- | Parse a single address
-parseAddress :: T.Text -> Maybe Address
-parseAddress a = either (const Nothing) Just $ parseOnly address a
-
--- | 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.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 {partContent = ContentText t}):_) = Just t
-findBodyText ((MessagePart {partContent = ContentMsgRFC822 _}):_) = Nothing
+-- | Search for the first part which is a body
+findBodyText :: [MessagePart] -> [T.Text]
+findBodyText [] = []
+findBodyText ((MessagePart {partContent = ContentText t}):_) = T.lines t
+findBodyText ((MessagePart {partContent = ContentMsgRFC822 _}):_) = []
 findBodyText ((MessagePart {partContent = ContentMultipart sub}):ms) =
     case findBodyText sub of
-        Nothing -> findBodyText ms
-        Just x -> Just x
+        [] -> findBodyText ms
+        x  -> 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
+-- | Parse a reply into a mail message and the reply body
+parseReply :: (MonadHandler m, HandlerSite m ~ App) => Reply -> m (Mail, T.Text)
+parseReply reply = do
+    to <- parseAddrHeader "to" reply
+    cc <- parseAddrHeader "cc" reply
 
-fileToAttach :: FileInfo -> ResourceT IO Alternatives
-fileToAttach f = do
-    content <- fileSource f $$ CL.consume
-    return [Part (fileContentType f) Base64 (Just $ fileName f) [] (BL.fromChunks content)]
+    let extra = foldr M.delete (replyHeaders reply) ["to", "cc", "subject", "from"]
 
-fromAddresses :: (MonadHandler m, HandlerSite m ~ App) => m [(T.Text,Address)]
-fromAddresses = do
-    addrs <- extraFromAddresses <$> getExtra
-    forM addrs $ \a -> do
-        case parseOnly address a of
-            Left err -> do
-                setMessageI $ MsgInvalidEmail $ a <> " " <> T.pack err
-                return ("Invalid " <> a, Address Nothing "")
-            Right a' -> return (a, a')
+    let mail = Mail (Address Nothing "")
+                    to
+                    cc
+                    [] -- bcc
+                    [(T.encodeUtf8 $ CI.original k, v) | (k,v) <- M.toList extra]
+                    [] -- parts
 
+    let body = T.concat $
+                [ "On "
+                , T.pack (show $ messageTime $ replyOriginal reply)
+                , ", "
+                , fromMaybe "" $ M.lookup "from" $ messageHeaders $ replyOriginal reply
+                , " wrote:\n"
+                ] ++ map (T.append "> ") (findBodyText $ messageBody $ replyOriginal reply)
+
+    return (mail, body)
+
+-- | Create the body of the outgoing message
+createBody :: (MonadHandler m, HandlerSite m ~ App) => Textarea -> [FileInfo] -> m [Alternatives]
+createBody bodytext attach = do
+    attachParts <- liftResourceT $ forM attach $ \f -> do
+        content <- fileSource f $$ CL.consume
+        return [Part (fileContentType f) Base64 (Just $ fileName f) [] (BL.fromChunks content)]
+
+    let body = BL.fromChunks [T.encodeUtf8 $ unTextarea bodytext]
+
+    return $ [[Part "text/plain" QuotedPrintableText Nothing [] body]] ++ attachParts
+
+-- | Create a new message ID
+messageID :: (MonadHandler m, HandlerSite m ~ App) => m 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, ">"]
+
+-- | Create a field settings from a string.  The default IsString instance does not set the id.
+fStr :: T.Text -> FieldSettings site
+fStr i = FieldSettings (fromString $ T.unpack i) Nothing (Just i) Nothing []
+
+-- | Create a field setting from a message
+fI :: AppMessage -> T.Text -> FieldSettings App
+fI m i = FieldSettings (SomeMessage m) Nothing (Just i) Nothing []
+
+-- | The compose form
 composeForm :: Maybe Reply -> Form Mail
 composeForm 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
+    mmail <- lift $ maybe (return Nothing) (\x -> Just <$> parseReply x) mreply
 
-    faddrs <- fromAddresses
+    (from,fromView) <- mreq (selectField fromAddresses) (fStr "From") Nothing
+    (to,toView) <- mreq addressField (fStr "To") (mailTo . fst <$> mmail)
+    (cc,ccView) <- mopt addressField (fStr "CC") (Just . mailCc . fst <$> mmail)
+    (bcc,bccView) <- mopt addressField (fStr "BCC") Nothing
+    (subject,sView) <- mreq textField (fI MsgSubject "subj") $ M.lookup "subject" =<< (replyHeaders <$> mreply)
+    (head,hView) <- mopt headerField (fI MsgExtraHeader "hdrs") (Just . mailHeaders . fst <$> mmail)
+    (body,bView) <- mreq textareaField (fStr "Body") (Textarea . snd <$> mmail)
+    (attach,attachView) <- mopt multiFile (fI MsgAttach "attch") Nothing
 
-    (from,fromView) <- mreq (selectFieldList faddrs) (FieldSettings "From" Nothing (Just "from") Nothing []) Nothing
-    (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
+    parts <- case (,) <$> body <*> attach of
+               FormSuccess (b,a)   -> FormSuccess <$> createBody b (fromMaybe [] a)
+               FormFailure err     -> return $ FormFailure err
+               FormMissing         -> return $ FormMissing
+               
+    mid <- lift messageID
 
-    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
+    let mkHeaders s e = ("Subject", s) : ("Message-ID", mid) : fromMaybe [] e
         mail = Mail <$> from
                     <*> to
-                    <*> (maybe [] id <$> cc)
-                    <*> (maybe [] id <$> bcc)
+                    <*> (fromMaybe [] <$> cc)
+                    <*> (fromMaybe [] <$> bcc)
                     <*> (mkHeaders <$> subject <*> head)
-                    <*> (mkParts <$> body)
+                    <*> parts
 
         widget = [whamlet|
  #{fmsg}
 |]
     return (mail, widget)
 
+-----------------------------------------------------------------------------------------
+-- Handlers
+-----------------------------------------------------------------------------------------
+
 getComposeR :: Handler RepHtml
 getComposeR = do
     ((_,widget),enctype) <- runFormPost $ composeForm Nothing
         let err = [] :: [String]
         $(widgetFile "compose")
 
+-- | Helper function for reply and reply all
 replyHandler :: ReplyTo -> MessageID -> Handler RepHtml
 replyHandler rto m = do
     reply <- notmuchReply m rto
 getReplyAllR :: MessageID -> Handler RepHtml
 getReplyAllR = replyHandler ReplyAll
 
+-- | Create a unique filename and a date header from the current time
 filenameAndDate :: IO (FilePath, TL.Text)
 filenameAndDate = do t <- getCurrentTime >>= utcToLocalZonedTime
                      let ts = formatTime defaultTimeLocale "%F-%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
     ((result,widget),enctype) <- runFormPost $ composeForm Nothing
     case result of
         FormSuccess m -> do
-            mid <- messageID
-            msg <- liftIO $ renderMail' $ m {mailHeaders = mailHeaders m ++ [("Message-ID", mid)]}
+            msg <- liftIO $ renderMail' m
             let tmsg = TL.decodeUtf8 msg
 
             when production $ do

File src/Handler/ComposeFields.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.ComposeFields (
+    addressField
+  , parseAddress
+  , parseAddresses
+  , headerField
+  , multiFile
+) where
+
+import Import
+import StaticFiles
+
+import Data.Attoparsec.Text
+import Data.String (fromString)
+import Network.Mail.Mime (Address(..))
+
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Text.Email.Validate as E
+
+-- | 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
+
+-- | Checks if an email is valid
+checkAddr :: Address -> Either (SomeMessage App) Address
+checkAddr a@(Address _ e) | E.isValid (T.encodeUtf8 e) = Right a
+checkAddr (Address _ e) = Left $ SomeMessage $ MsgInvalidEmail e
+
+-- | Parse a single address
+parseAddress :: T.Text -> Either (SomeMessage App) Address
+parseAddress t = case parseOnly' address t of
+                       Left err -> Left $ fromString $ concat ["Error parsing ", T.unpack t, ": ", err]
+                       Right a  -> checkAddr a
+
+-- | Parse a list of addresses separated by commas
+parseAddresses :: T.Text -> Either (SomeMessage App) [Address]
+parseAddresses t = case parseOnly' addresses t of
+                       Left err -> Left $ fromString $ concat ["Error parsing ", T.unpack t, ": ", err]
+                       Right [(Address Nothing "")] -> Right []
+                       Right a -> mapM checkAddr a
+
+showAddress :: Address -> T.Text
+showAddress (Address {addressName = Just name, addressEmail = e}) = T.concat [name, " <", e, ">"]
+showAddress (Address {addressName = Nothing, addressEmail = e}) = e
+
+{-
+addrWidget :: FieldViewFunc (HandlerT App IO) [Address]
+addrWidget theID name attrs val isReq = do 
+    addStylesheet $ StaticR css_select2_css
+    addScript $ StaticR js_select2_3_4_0_min_js
+
+    let addrs = map showAddress $ either (const []) id val
+
+    toWidget $ [julius|
+$(document).ready(function() {
+    $(#{toJSON ("#" <> theID)}).select2({tags:#{toJSON addrs}, tokenSeparators: [","]});
+});
+|]
+
+    [whamlet|<input type=hidden ##{theID} name=#{name} .address-select :isReq:required *{attrs}>|]
+-}
+
+addrWidget :: FieldViewFunc (HandlerT App IO) [Address]
+addrWidget theID name attrs val isReq = do 
+    let addrs = either id (T.concat . map showAddress) val
+    [whamlet|
+      <input type=text ##{theID} name=#{name} :isReq:required value="#{addrs}" *{attrs}>
+    |]
+
+addressField :: Field (HandlerT App IO) [Address]
+addressField = Field
+  { fieldParse = \addr _ -> case addr of
+                              []    -> return $ Right Nothing
+                              (a:_) -> return $ Just <$> parseAddresses a
+  , fieldView = addrWidget
+  , fieldEnctype = UrlEncoded
+  }
+
+-- | Parse a header
+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)
+
+-- | Parse a list of headers
+headers :: Parser [(B.ByteString, T.Text)]
+headers = sepBy header endOfLine <?> "Headers"
+
+headerField :: Field (HandlerT App IO) [(B.ByteString,T.Text)]
+headerField = Field 
+    { fieldParse = \x _ -> case x of
+                             [] -> return $ Right Nothing
+                             ("":_) -> return $ Right Nothing
+                             (n:_) -> return $ case parseOnly' headers n of
+                                                 Left err -> Left $ fromString err
+                                                 Right [] -> Right $ Nothing
+                                                 Right h  -> Right $ Just h
+    , fieldView = \theId name attrs val isReq -> do
+        let hdrs = case val of
+                     Left txt -> txt
+                     Right vals -> T.intercalate "\n" [ T.decodeUtf8 x <> ": " <> y | (x,y) <- vals]
+        [whamlet|
+<textarea id=#{theId} name=#{name} *{attrs} rows=4 cols=50 wrap=off :isReq:required>
+    #{hdrs}
+|]
+    , 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}>
+|]
+
+
+-- | 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

File src/Import.hs

 import Data.Conduit
 import Data.List (find)
 import Data.Monoid (Monoid (mappend, mempty, mconcat), (<>))
-import Data.Maybe (listToMaybe)
+import Data.Maybe (listToMaybe, fromMaybe, catMaybes)
 import Yesod hiding (loadConfig)

File templates/compose.lucius

-textarea#body {
+textarea#Body {
     height: 200px;
 }
-textarea#extraheaders {
+textarea#hdrs {
     white-space: nowrap;
     overflow: auto;
 }
 @media (max-width: 800px) {
-    textarea#body {
+    textarea#Body {
         width: 100%;
     }
 }
 @media (min-width: 801px) {
-    textarea#body {
+    textarea#Body {
         width: 650px;
     }
-    textarea#extraheaders, div.controls input {
+    textarea#hdrs, div.controls input {
         width: 400px;
     }
 }