diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8a24388d0..41e50c599 100644 --- a/messages/uniworx/de.msg +++ b/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
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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 06d200c2a..7d521389f 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 933730346..da9ed5a2e 100644 --- a/src/Handler/Utils/Communication.hs +++ b/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") diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 89e4f1f70..ff84ddfb9 100644 --- a/src/Handler/Utils/Csv.hs +++ b/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) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index f6f8e76bc..bbc0f02d9 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 182ed6cbc..7a35229d0 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/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 diff --git a/src/Mail.hs b/src/Mail.hs index 03d14b83d..60baf72b5 100644 --- a/src/Mail.hs +++ b/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 () diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 7861f5c3d..83cc59c14 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/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" ] diff --git a/src/Settings.hs b/src/Settings.hs index df9bce882..48d70d396 100644 --- a/src/Settings.hs +++ b/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. diff --git a/src/Settings/Mime.hs b/src/Settings/Mime.hs new file mode 100644 index 000000000..afa03594b --- /dev/null +++ b/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") diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index e864f9e04..0c071f864 100644 --- a/src/Utils/Csv.hs +++ b/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)