fix(communication): make communication form more intuitive

Fixes #387

messages/uniworx/de.msg

@@ -1135,8 +1135,10 @@ NavigationFavourites: Favoriten
 
 CommSubject: Betreff
 CommBody: Nachricht
+CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit <br> eingefügt werden.
 CommRecipients: Empfänger
 CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
+CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
 CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
 CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
 

src/Handler/Sheet.hs

@@ -686,7 +686,7 @@ defaultLoads shid = do
     return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
   where
     toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
-    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
+    toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad)
 
 
 correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
@@ -809,7 +809,7 @@ correctorForm shid = wFormToAForm $ do
 
         postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
         postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
-        postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
+        postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector))
 
     filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
     filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
@@ -906,7 +906,7 @@ correctorInvitationConfig = InvitationConfig{..}
       itAuthority <- liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
+    invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
     invitationInsertHook _ _ _ _ = id
     invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
     invitationUltDest (Entity _ Sheet{..}) _ = do

src/Handler/Utils/Communication.hs

@@ -150,9 +150,9 @@ commR CommunicationRoute{..} =  do
                    -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
                    -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
                    -> Widget
-          miLayout liveliness state cellWdgts _delButtons addWdgts = do
+          miLayout liveliness cState cellWdgts _delButtons addWdgts = do
             checkedIdentBase <- newIdent
-            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state
+            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
                 checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
                 hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
                 categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
@@ -165,10 +165,13 @@ commR CommunicationRoute{..} =  do
           postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
           postProcess = Set.fromList . map fst . filter snd . Map.elems
 
+  recipientsListMsg <- messageI Info MsgCommRecipientsList
+
   ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
     <$> recipientAForm
+    <*  aformMessage recipientsListMsg
     <*> aopt textField (fslI  MsgCommSubject)     Nothing
-    <*> areq htmlField (fslpI MsgCommBody "Html") Nothing
+    <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing
   formResult commRes $ \comm -> do
     runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
     addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
@@ -183,4 +186,3 @@ commR CommunicationRoute{..} =  do
   siteLayoutMsg crHeading $ do
     setTitleI crHeading
     formWdgt
-    $(i18nWidgetFile "html-input")

src/Handler/Utils/Csv.hs

@@ -1,8 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Csv
-  ( typeCsv, extensionCsv
-  , decodeCsv
+  ( decodeCsv
   , encodeCsv
   , encodeDefaultOrderedCsv
   , respondCsv, respondCsvDB
@@ -12,9 +11,6 @@ module Handler.Utils.Csv
   , ToNamedRecord(..), FromNamedRecord(..)
   , DefaultOrdered(..)
   , ToField(..), FromField(..)
-  , CsvRendered(..)
-  , toCsvRendered
-  , toDefaultOrderedCsvRendered
   ) where
 
 import Import hiding (Header, mapM_)
@@ -40,18 +36,6 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Attoparsec.ByteString.Lazy as A
 
 
-deriving instance Typeable CsvParseError
-instance Exception CsvParseError
-
-
-typeCsv, typeCsv' :: ContentType
-typeCsv = simpleContentType typeCsv'
-typeCsv' = "text/csv; charset=UTF-8; header=present"
-
-extensionCsv :: Extension
-extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
-
-
 decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
 decodeCsv = transPipe throwExceptT $ do
   testBuffer <- accumTestBuffer LBS.empty
@@ -173,11 +157,6 @@ fileSourceCsv :: ( FromNamedRecord csv
 fileSourceCsv = (.| decodeCsv) . fileSource
 
 
-data CsvRendered = CsvRendered
-  { csvRenderedHeader :: Header
-  , csvRenderedData :: [NamedRecord]
-  } deriving (Eq, Read, Show, Generic, Typeable)
-
 instance ToWidget UniWorX CsvRendered where
   toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered")
     where
@@ -188,21 +167,3 @@ instance ToWidget UniWorX CsvRendered where
                 ]
 
       headers = decodeUtf8 <$> Vector.toList csvRenderedHeader
-
-toCsvRendered :: forall mono.
-                 ( ToNamedRecord (Element mono)
-                 , MonoFoldable mono
-                 )
-              => Header
-              -> mono -> CsvRendered
-toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..}
-  where
-    csvRenderedData   = map toNamedRecord csvs
-  
-toDefaultOrderedCsvRendered :: forall mono.
-                               ( ToNamedRecord (Element mono)
-                               , DefaultOrdered (Element mono)
-                               , MonoFoldable mono
-                               )
-                            => mono -> CsvRendered
-toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)

src/Import/NoModel.hs

@@ -84,6 +84,10 @@ import Control.Monad.Trans.Reader as Import
   ( reader, Reader, runReader, mapReader, withReader
   , ReaderT(..), mapReaderT, withReaderT
   )
+import Control.Monad.Trans.State as Import
+  ( state, State, runState, mapState, withState
+  , StateT(..), mapStateT, withStateT
+  )
 import Control.Monad.Base as Import
 import Control.Monad.Catch as Import hiding (Handler(..))
 import Control.Monad.Trans.Control as Import hiding (embed)

src/Jobs/Handler/SendCourseCommunication.hs

@@ -6,8 +6,6 @@ import Import
 
 import Handler.Utils
 
-import qualified Data.Set as Set
-
 import qualified Data.CaseInsensitive as CI
 
 
@@ -26,11 +24,11 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
   either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
     void $ setMailObjectUUID jMailObjectUUID
     _mailFrom .= userAddress sender
-    if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
-      | jRecipientEmail == Right jSender
-      -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
-      | otherwise
-      -> addMailHeader "Cc" "Undisclosed Recipients:;"
+    addMailHeader "Cc" "Undisclosed Recipients:;"
     addMailHeader "Auto-Submitted" "no"
     setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
     void $ addPart jMailContent
+    when (jRecipientEmail == Right jSender) $
+      addPart' $ do
+        partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv
+        toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses

src/Mail.hs

@@ -21,7 +21,7 @@ module Mail
   , PrioritisedAlternatives
   , ToMailPart(..)
   , addAlternatives, provideAlternative, providePreferredAlternative
-  , addPart
+  , addPart, addPart', modifyPart, partIsAttachment
   , MonadHeader(..)
   , MailHeader
   , MailObjectId
@@ -43,6 +43,8 @@ import Model.Types.TH.JSON
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
 
+import Settings.Mime
+
 import Data.Monoid (Last(..))
 import Control.Monad.Trans.RWS (RWST(..))
 import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
@@ -71,6 +73,10 @@ import qualified Data.ByteString.Lazy as LBS
 
 import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT)
 import Utils.Lens.TH
+
+import Utils.Csv (CsvRendered(..), typeCsv')
+import qualified Data.Csv as Csv
+
 import Control.Lens hiding (from)
 import Control.Lens.Extras (is)
 
@@ -336,7 +342,7 @@ instance YesodMail site => ToMailPart site (StateT Part (HandlerFor site) a) whe
 
 instance YesodMail site => ToMailPart site LT.Text where
   toMailPart text = do
-    _partType .= "text/plain; charset=utf-8"
+    _partType .= decodeUtf8 typePlain
     _partEncoding .= QuotedPrintableText
     _partContent .= encodeUtf8 text
 
@@ -348,7 +354,7 @@ instance YesodMail site => ToMailPart site LTB.Builder where
 
 instance YesodMail site => ToMailPart site Html where
   toMailPart html = do
-    _partType .= "text/html; charset=utf-8"
+    _partType .= decodeUtf8 typeHtml
     _partEncoding .= QuotedPrintableText
     _partContent .= renderMarkup html
 
@@ -372,10 +378,16 @@ instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site
 
 instance YesodMail site => ToMailPart site Aeson.Value where
   toMailPart val = do
-    _partType .= "application/json; charset=utf-8"
+    _partType .= decodeUtf8 typeJson
     _partEncoding .= QuotedPrintableText
     _partContent .= Aeson.encodePretty val
 
+instance YesodMail site => ToMailPart site CsvRendered where
+  toMailPart CsvRendered{..} = do
+    _partType .= decodeUtf8 typeCsv'
+    _partEncoding .= QuotedPrintableText
+    _partContent .= Csv.encodeByName csvRenderedHeader csvRenderedData
+
 
 addAlternatives :: (MonadMail m)
                 => Writer (PrioritisedAlternatives m) ()
@@ -396,20 +408,35 @@ addPart :: ( MonadMail m
            , HandlerSite m ~ site
            , ToMailPart site a
            ) => a -> m (MailPartReturn site a)
-addPart part = do
-  (ret, part') <- runStateT (toMailPart part) initialPart
+addPart = addPart' . toMailPart
+
+addPart' :: MonadMail m
+         => StateT Part m a
+         -> m a
+addPart' part = do
+  (ret, part') <- runStateT part initialPart
   modify . Mime.addPart $ pure part'
   return ret
 
 initialPart :: Part
 initialPart = Part
-  { partType = "text/plain"
-  , partEncoding = None
+  { partType = decodeUtf8 defaultMimeType
+  , partEncoding = Base64
   , partFilename = Nothing
   , partHeaders = []
   , partContent = mempty
   }
 
+modifyPart :: (MonadMail m, HandlerSite m ~ site, YesodMail site)
+           => StateT Part (HandlerFor site) a
+           -> StateT Part m a
+modifyPart = toMailPart
+
+partIsAttachment :: (Textual t, MonadMail m, HandlerSite m ~ site, YesodMail site)
+                 => t
+                 -> StateT Part m ()
+partIsAttachment (repack -> fName) = modifyPart $ _partFilename .= Just fName
+
 
 class MonadHandler m => MonadHeader m where
   modifyHeaders :: (Headers -> Headers) -> m ()

src/Network/Mail/Mime/Instances.hs

@@ -14,6 +14,8 @@ import Data.Aeson.TH
 import Utils.PathPiece
 
 import Utils (assertM)
+
+import qualified Data.Csv as Csv
   
 
 deriving instance Read Address
@@ -32,3 +34,13 @@ instance FromJSON Address where
     addressName <- assertM (not . null) <$> (obj .:? "name")
     addressEmail <- obj .: "email"
     return Address{..}
+
+
+instance Csv.ToNamedRecord Address where
+  toNamedRecord Address{..} = Csv.namedRecord
+    [ "name" Csv..= addressName
+    , "email" Csv..= addressEmail
+    ]
+
+instance Csv.DefaultOrdered Address where
+  headerOrder _ = Csv.header [ "name", "email" ]

src/Settings.hs

@@ -9,6 +9,7 @@
 module Settings
   ( module Settings
   , module Settings.Cluster
+  , module Settings.Mime
   ) where
 
 import           Import.NoModel
@@ -58,6 +59,7 @@ import qualified Database.Memcached.Binary.Types as Memcached
 
 import Model
 import Settings.Cluster
+import Settings.Mime
 
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
@@ -67,10 +69,6 @@ import Jose.Jwt (JwtEncoding(..))
 
 import System.FilePath.Glob
 import Handler.Utils.Submission.TH
-import Network.Mime.TH
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
 
 
 -- | Runtime settings to configure this application. These settings can be
@@ -458,18 +456,6 @@ widgetFileSettings = def
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
 
-mimeMap :: MimeMap
-mimeMap = $(mimeMapFile "config/mimetypes")
-
-mimeLookup :: FileName -> MimeType
-mimeLookup = mimeByExt mimeMap defaultMimeType
-
-mimeExtensions :: MimeType -> Set Extension
-mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
-
-archiveTypes :: Set MimeType
-archiveTypes = $(mimeSetFile "config/archive-types")
-
 -- The rest of this file contains settings which rarely need changing by a
 -- user.
 

src/Settings/Mime.hs

@@ -0,0 +1,31 @@
+module Settings.Mime
+  ( mimeMap
+  , mimeLookup
+  , mimeExtensions
+  , archiveTypes
+  , module Network.Mime
+  ) where
+
+import ClassyPrelude
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Network.Mime
+  ( FileName, MimeType, MimeMap, Extension
+  , mimeByExt, defaultMimeType
+  )
+import Network.Mime.TH
+
+
+mimeMap :: MimeMap
+mimeMap = $(mimeMapFile "config/mimetypes")
+
+mimeLookup :: FileName -> MimeType
+mimeLookup = mimeByExt mimeMap defaultMimeType
+
+mimeExtensions :: MimeType -> Set Extension
+mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
+
+archiveTypes :: Set MimeType
+archiveTypes = $(mimeSetFile "config/archive-types")

src/Utils/Csv.hs

@@ -1,14 +1,39 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
 module Utils.Csv
-  ( pathPieceCsv
+  ( typeCsv, typeCsv', extensionCsv
+  , pathPieceCsv
   , (.:??)
+  , CsvRendered(..)
+  , toCsvRendered
+  , toDefaultOrderedCsvRendered
   ) where
 
 import ClassyPrelude hiding (lookup)
+import Settings.Mime
+  
 import Data.Csv hiding (Name)
+import Data.Csv.Conduit (CsvParseError)
   
 import Language.Haskell.TH (Name)
 import Language.Haskell.TH.Lib
 
+import Yesod.Core.Content (ContentType, simpleContentType)
+
+import qualified Data.Map as Map
+
+
+deriving instance Typeable CsvParseError
+instance Exception CsvParseError
+
+
+typeCsv, typeCsv' :: ContentType
+typeCsv = simpleContentType typeCsv'
+typeCsv' = "text/csv; charset=UTF-8; header=present"
+
+extensionCsv :: Extension
+extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
+
 
 pathPieceCsv :: Name -> DecsQ
 pathPieceCsv (conT -> t) =
@@ -22,3 +47,27 @@ pathPieceCsv (conT -> t) =
 
 (.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a)
 m .:?? name = lookup m name <|> return Nothing
+
+
+data CsvRendered = CsvRendered
+  { csvRenderedHeader :: Header
+  , csvRenderedData :: [NamedRecord]
+  } deriving (Eq, Read, Show, Generic, Typeable)
+
+toCsvRendered :: forall mono.
+                 ( ToNamedRecord (Element mono)
+                 , MonoFoldable mono
+                 )
+              => Header
+              -> mono -> CsvRendered
+toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..}
+  where
+    csvRenderedData   = map toNamedRecord csvs
+  
+toDefaultOrderedCsvRendered :: forall mono.
+                               ( ToNamedRecord (Element mono)
+                               , DefaultOrdered (Element mono)
+                               , MonoFoldable mono
+                               )
+                            => mono -> CsvRendered
+toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)