Merge branch '429-anhange-an-kurs-und-tutoriumsmitteilungen' into 'master'
Resolve "Anhänge an Kurs- und Tutoriumsmitteilungen" Closes #429 See merge request uni2work/uni2work!73
This commit is contained in:
Sarah Vaupel
commit
342c465979
@ -290,3 +290,5 @@ bot-mitigations:
|
||||
- only-logged-in-table-sorting
|
||||
|
||||
volatile-cluster-settings-cache-time: 10
|
||||
|
||||
communication-attachments-max-size: 20971520 # 20MiB
|
||||
|
||||
@ -186,6 +186,7 @@ UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen ang
|
||||
UploadModeExtensionRestrictionMultipleTip: Einschränkung von Dateiendungen erfolgt für alle hochgeladenen Dateien, auch innerhalb von ZIP-Archiven.
|
||||
FileUploadMaxSize maxSize@Text: Datei darf maximal #{maxSize} groß sein
|
||||
FileUploadMaxSizeMultiple maxSize@Text: Dateien dürfen jeweils maximal #{maxSize} groß sein
|
||||
FileUploadCumulativeMaxSize maxSize@Text: Dateien dürfen insgesamt maximal #{maxSize} groß sein
|
||||
|
||||
InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
|
||||
InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte.
|
||||
|
||||
@ -186,6 +186,8 @@ UploadModeExtensionRestrictionTip: Comma-separated. If no file extensions are sp
|
||||
UploadModeExtensionRestrictionMultipleTip: Checks for valid file extension are performed for all uploaded files, including those packed within zip-archives.
|
||||
FileUploadMaxSize maxSize: File may be up to #{maxSize} in size
|
||||
FileUploadMaxSizeMultiple maxSize: Files may each be up to #{maxSize} in size
|
||||
FileUploadCumulativeMaxSize maxSize: Files may be no larger than #{maxSize} in total
|
||||
|
||||
InvalidPseudonym pseudonym: Invalid pseudonym “#{pseudonym}”
|
||||
InvalidPseudonymSubmissionIgnored oPseudonyms iPseudonym: The submission with pseudonyms “#{oPseudonyms}” has been ignored since “#{iPseudonym}” could not be automatically corrected to be a valid pseudonym.
|
||||
PseudonymAutocorrections: Suggestions:
|
||||
|
||||
@ -17,6 +17,8 @@ RGTutorialParticipants tutn@TutorialName: Tutorium-Teilnehmer:innen (#{tutn})
|
||||
RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
|
||||
RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
|
||||
CommSubject: Betreff
|
||||
CommAttachments: Anhänge
|
||||
CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zum Kurs anmelden, haben Zugriff auf die Datei.
|
||||
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
|
||||
CommTestSuccess: Nachricht wurde zu Testzwecken nur an Sie selbst versandt
|
||||
|
||||
@ -53,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximale Dateigröße darf nicht negativ sein
|
||||
UploadSpecificFileEmptyOk: Leere Uploads erlauben
|
||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||
GenericFileFieldFileTooLarge file@FilePath: „#{file}“ ist zu groß
|
||||
GenericFileFieldCumulativeTooLarge: Hochgeladene Dateien sind zu groß
|
||||
GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
|
||||
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
|
||||
UploadAtLeastOneNonemptyFile: Bitte mindestens eine nichtleere Datei hochladen.
|
||||
|
||||
@ -17,6 +17,8 @@ RGTutorialParticipants tutn: Tutorial participants (#{tutn})
|
||||
RGExamRegistered examn: Registered for exam “#{examn}”
|
||||
RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
|
||||
CommSubject: Subject
|
||||
CommAttachments: Attachments
|
||||
CommAttachmentsTip: In general it is preferable to upload files as course material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course at a later date.
|
||||
CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
|
||||
CommTestSuccess: Message was sent only to yourself for testing purposes
|
||||
|
||||
@ -53,6 +55,7 @@ UploadSpecificFileMaxSizeNegative: Maximum filesize may not be negative
|
||||
UploadSpecificFileEmptyOk: Allow empty uploads
|
||||
UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}”
|
||||
GenericFileFieldFileTooLarge file: “#{file}” is too large
|
||||
GenericFileFieldCumulativeTooLarge: Uploaded files are too large
|
||||
GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension
|
||||
OnlyUploadOneFile: Please only upload one file
|
||||
UploadAtLeastOneNonemptyFile: Please upload at least one nonempty file.
|
||||
|
||||
@ -27,10 +27,10 @@ addStaticContent ext _mime content = do
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
addItem = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
catchIf Memcached.isKeyNotFound touch . const $
|
||||
handleIf Memcached.isKeyExists (const $ return ()) add
|
||||
handleIf Memcached.isKeyExists (const $ return ()) addItem
|
||||
return . Left $ pack absoluteLink
|
||||
where
|
||||
-- Generate a unique filename based on the content itself, this is used
|
||||
|
||||
@ -78,16 +78,16 @@ data CommunicationRoute = CommunicationRoute
|
||||
|
||||
data Communication = Communication
|
||||
{ cRecipients :: Set (Either UserEmail UserId)
|
||||
, cSubject :: Maybe Text
|
||||
, cBody :: Html
|
||||
, cContent :: CommunicationContent
|
||||
}
|
||||
|
||||
makeLenses_ ''Communication
|
||||
|
||||
|
||||
crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
crJobsCourseCommunication jCourse Communication{..} = do
|
||||
jSender <- requireAuthId
|
||||
let jSubject = cSubject
|
||||
jMailContent = cBody
|
||||
let jMailContent = cContent
|
||||
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
||||
jMailObjectUUID <- liftIO getRandom
|
||||
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
||||
@ -99,7 +99,7 @@ crTestJobsCourseCommunication jCourse comm = do
|
||||
jSender <- requireAuthId
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let comm' = comm { cSubject = Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) $ cSubject comm }
|
||||
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
|
||||
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
||||
|
||||
|
||||
@ -206,11 +206,24 @@ commR CommunicationRoute{..} = do
|
||||
|
||||
recipientsListMsg <- messageI Info MsgCommRecipientsList
|
||||
|
||||
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
|
||||
let attachmentField = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True False
|
||||
, fieldMultiple = True
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
|
||||
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
|
||||
<$> recipientAForm
|
||||
<* aformMessage recipientsListMsg
|
||||
<*> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
|
||||
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
|
||||
<*> ( CommunicationContent
|
||||
<$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
|
||||
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
|
||||
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
|
||||
)
|
||||
formResult commRes $ \case
|
||||
(comm, BtnCommunicationSend) -> do
|
||||
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Files
|
||||
( sourceFile, sourceFile'
|
||||
, sourceFiles, sourceFiles'
|
||||
@ -9,6 +11,7 @@ module Handler.Utils.Files
|
||||
|
||||
import Import.NoFoundation hiding (First(..))
|
||||
import Foundation.Type
|
||||
import Foundation.DB
|
||||
import Utils.Metrics
|
||||
|
||||
import Data.Monoid (First(..))
|
||||
@ -181,6 +184,11 @@ sourceFiles' = C.map sourceFile'
|
||||
sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile
|
||||
sourceFile' = sourceFile . view (_FileReference . _1)
|
||||
|
||||
|
||||
instance (YesodMail UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => ToMailPart UniWorX FileReference where
|
||||
toMailPart = toMailPart <=< liftHandler . runDBRead . withReaderT projectBackend . toPureFile . sourceFile'
|
||||
|
||||
|
||||
respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
|
||||
=> Maybe UTCTime -> MimeType
|
||||
-> FileReference
|
||||
|
||||
@ -998,15 +998,20 @@ genericFileField mkOpts = Field{..}
|
||||
= not (permittedExtension opts fName)
|
||||
&& (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip)
|
||||
|
||||
whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do
|
||||
fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE
|
||||
when (fLength > maxSize) $ do
|
||||
when (is _Just mIdent) $
|
||||
liftHandler . runDB . runConduit $
|
||||
mapM_ (transPipe lift . handleFile) files
|
||||
.| handleUpload opts mIdent
|
||||
.| C.sinkNull
|
||||
throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo
|
||||
whenIsJust (ignoreNothing min fieldMaxFileSize fieldMaxCumulativeSize) $ \takeSize ->
|
||||
flip evalAccumT mempty . forM_ files $ \fInfo -> do
|
||||
fLength <- lift . runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ takeSize) .| C.lengthE
|
||||
add $ Sum fLength
|
||||
Sum cummSize <- look
|
||||
when (NTop (Just cummSize) > NTop fieldMaxCumulativeSize || NTop (Just fLength) > NTop fieldMaxFileSize) $ do
|
||||
when (is _Just mIdent) $
|
||||
lift . liftHandler . runDB . runConduit $
|
||||
mapM_ (transPipe lift . handleFile) files
|
||||
.| handleUpload opts mIdent
|
||||
.| C.sinkNull
|
||||
when (NTop (Just fLength) > NTop fieldMaxFileSize) $ do
|
||||
lift . throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo
|
||||
lift . throwE $ SomeMessage MsgGenericFileFieldCumulativeTooLarge
|
||||
|
||||
if | invExt : _ <- filter invalidUploadExtension uploadedFilenames
|
||||
-> do
|
||||
@ -1125,7 +1130,7 @@ fileFieldMultiple = genericFileField $ return FileField
|
||||
, fieldMultiple = True
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
@ -1145,7 +1150,7 @@ singleFileField prev = genericFileField $ do
|
||||
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
||||
| FileReference{..} <- Set.toList permitted
|
||||
]
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
@ -1161,7 +1166,7 @@ specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitle
|
||||
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
||||
| FileReference{..} <- Set.toList previous
|
||||
]
|
||||
, fieldMaxFileSize = specificFileMaxSize
|
||||
, fieldMaxFileSize = specificFileMaxSize, fieldMaxCumulativeSize = Nothing
|
||||
, fieldAllEmptyOk = specificFileEmptyOk
|
||||
}
|
||||
where
|
||||
@ -1189,7 +1194,7 @@ zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do
|
||||
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
||||
| FileReference{..} <- Set.toList previous
|
||||
]
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
|
||||
, fieldAllEmptyOk = emptyOk
|
||||
}
|
||||
|
||||
@ -1232,7 +1237,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
|
||||
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
||||
| FileReference{..} <- Set.toList permitted
|
||||
]
|
||||
, fieldMaxFileSize = Nothing
|
||||
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = Nothing
|
||||
, fieldAllEmptyOk = True
|
||||
}
|
||||
|
||||
|
||||
@ -70,6 +70,7 @@ instance ToJSON (FileField FileIdent) where
|
||||
, pure $ "multiple" JSON..= fieldMultiple
|
||||
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
|
||||
, pure $ "max-file-size" JSON..= fieldMaxFileSize
|
||||
, pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize
|
||||
, pure $ "additional-files" JSON..= addFiles'
|
||||
]
|
||||
where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object
|
||||
@ -83,6 +84,7 @@ instance FromJSON (FileField FileIdent) where
|
||||
fieldMultiple <- o JSON..: "multiple"
|
||||
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
||||
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
||||
fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-size"
|
||||
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
||||
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
||||
fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do
|
||||
|
||||
@ -118,6 +118,11 @@ import Control.Monad.Trans.State as Import
|
||||
( State, runState, mapState, withState
|
||||
, StateT(..), mapStateT, withStateT
|
||||
)
|
||||
import Control.Monad.Trans.Accum as Import
|
||||
( Accum, runAccum, mapAccum
|
||||
, AccumT, runAccumT, execAccumT, evalAccumT, mapAccumT
|
||||
, look, looks, add
|
||||
)
|
||||
import Control.Monad.State.Class as Import (MonadState(state))
|
||||
import Control.Monad.Trans.Writer.Lazy as Import
|
||||
( Writer, runWriter, mapWriter, execWriter
|
||||
|
||||
@ -47,6 +47,9 @@ import qualified Data.Foldable as F
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Jobs.Types
|
||||
import Data.Aeson.Lens (_JSON)
|
||||
|
||||
|
||||
dispatchJobPruneSessionFiles :: JobHandler UniWorX
|
||||
dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin
|
||||
@ -83,6 +86,9 @@ workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece
|
||||
, (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
|
||||
]
|
||||
|
||||
jobFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) ()
|
||||
jobFileReferences = E.selectSource (E.from $ pure . (E.^. QueuedJobContent)) .| C.mapMaybe (preview _JSON . E.unValue) .| awaitForever (mapMOf_ (typesCustom @JobChildren @Job @Job @FileContentReference @FileContentReference) yield)
|
||||
|
||||
|
||||
dispatchJobDetectMissingFiles :: JobHandler UniWorX
|
||||
dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
|
||||
@ -103,8 +109,10 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
|
||||
E.distinctOnOrderBy [E.asc ref] $ return ref
|
||||
transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind)
|
||||
|
||||
iforM_ workflowFileReferences $ \refKind refSource ->
|
||||
transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
|
||||
let useRefSource refKind refSource = transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
|
||||
iforM_ workflowFileReferences useRefSource
|
||||
useRefSource (nameToPathPiece ''Job) jobFileReferences
|
||||
|
||||
|
||||
let allMissingDb :: Set Minio.Object
|
||||
allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
|
||||
@ -204,14 +212,16 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
|
||||
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
|
||||
E.where_ $ chunkIdFilter unreferencedChunkHash
|
||||
|
||||
let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
|
||||
let unmarkSourceFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
|
||||
let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
|
||||
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
|
||||
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
|
||||
return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
|
||||
E.where_ $ chunkIdFilter unreferencedChunkHash
|
||||
unmarkRefSource refSource = runConduit $ refSource .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkSourceFiles
|
||||
chunkSize = 100
|
||||
in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles
|
||||
unmarkRefSource $ sequence_ workflowFileReferences
|
||||
unmarkRefSource jobFileReferences
|
||||
|
||||
let
|
||||
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
|
||||
|
||||
@ -20,10 +20,9 @@ dispatchJobSendCourseCommunication :: Either UserEmail UserId
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> UUID
|
||||
-> Maybe Text
|
||||
-> Html
|
||||
-> CommunicationContent
|
||||
-> JobHandler UniWorX
|
||||
dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = JobHandlerException $ do
|
||||
dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
|
||||
(sender, Course{..}) <- runDB $ (,)
|
||||
<$> getJust jSender
|
||||
<*> getJust jCourse
|
||||
@ -34,8 +33,9 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
|
||||
_mailFrom .= userAddressFrom sender
|
||||
addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
|
||||
addMailHeader "Auto-Submitted" "no"
|
||||
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
|
||||
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
forM_ ccAttachments $ addPart' . toMailPart
|
||||
when (jRecipientEmail == Right jSender) $
|
||||
addPart' $ do
|
||||
partIsAttachmentCsv MsgCommAllRecipients
|
||||
|
||||
@ -44,7 +44,7 @@ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
|
||||
import System.Clock (getTime, Clock(Monotonic), TimeSpec)
|
||||
import GHC.Conc (unsafeIOToSTM)
|
||||
|
||||
import Data.Generics.Product.Types (Children, ChGeneric)
|
||||
import Data.Generics.Product.Types (Children, ChGeneric, HasTypesCustom(..))
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
@ -67,8 +67,7 @@ data Job
|
||||
, jCourse :: CourseId
|
||||
, jSender :: UserId
|
||||
, jMailObjectUUID :: UUID
|
||||
, jSubject :: Maybe Text
|
||||
, jMailContent :: Html
|
||||
, jMailContent :: CommunicationContent
|
||||
}
|
||||
| JobInvitation { jInviter :: Maybe UserId
|
||||
, jInvitee :: UserEmail
|
||||
@ -169,10 +168,14 @@ type family ChildrenJobChildren a where
|
||||
ChildrenJobChildren UUID = '[]
|
||||
ChildrenJobChildren (Key a) = '[]
|
||||
ChildrenJobChildren (CI a) = '[]
|
||||
ChildrenJobChildren (Set a) = '[]
|
||||
ChildrenJobChildren (Set v) = '[v]
|
||||
ChildrenJobChildren MailContext = '[]
|
||||
ChildrenJobChildren (Digest a) = '[]
|
||||
|
||||
ChildrenJobChildren a = Children ChGeneric a
|
||||
|
||||
instance (Ord b', HasTypesCustom JobChildren a' b' a b) => HasTypesCustom JobChildren (Set a') (Set b') a b where
|
||||
typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @JobChildren
|
||||
|
||||
|
||||
classifyJob :: Job -> String
|
||||
|
||||
23
src/Mail.hs
23
src/Mail.hs
@ -42,6 +42,7 @@ import Data.Kind (Type)
|
||||
|
||||
import Model.Types.Languages
|
||||
import Model.Types.Csv
|
||||
import Model.Types.File
|
||||
|
||||
import Network.Mail.Mime hiding (addPart, addAttachment)
|
||||
import qualified Network.Mail.Mime as Mime (addPart)
|
||||
@ -89,7 +90,7 @@ import qualified Data.Binary as Binary
|
||||
import "network-bsd" Network.BSD (getHostName)
|
||||
|
||||
import Data.Time.Zones (utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
|
||||
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..))
|
||||
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..), utcToZonedTime, utc)
|
||||
import Data.Time.Format (rfc822DateFormat)
|
||||
|
||||
import Network.HaskellNet.SMTP (SMTPConnection)
|
||||
@ -123,6 +124,12 @@ import Language.Haskell.TH (nameBase)
|
||||
|
||||
import Network.Mail.Mime.Instances()
|
||||
|
||||
import Data.Char (isLatin1)
|
||||
import Data.Text.Lazy.Encoding (decodeUtf8')
|
||||
import System.FilePath (takeFileName)
|
||||
import Network.HTTP.Types.Header (hETag)
|
||||
import Web.HttpApiData (ToHttpApiData(toHeader))
|
||||
|
||||
|
||||
makeLenses_ ''Address
|
||||
makeLenses_ ''Mail
|
||||
@ -346,6 +353,20 @@ instance YesodMail site => ToMailPart site Html where
|
||||
_partEncoding .= QuotedPrintableText
|
||||
_partContent .= PartContent (renderMarkup html)
|
||||
|
||||
instance YesodMail site => ToMailPart site PureFile where
|
||||
toMailPart file@File{fileTitle, fileModified} = do
|
||||
_partDisposition .= AttachmentDisposition (pack $ takeFileName fileTitle)
|
||||
_partType .= decodeUtf8 (mimeLookup $ pack fileTitle)
|
||||
let
|
||||
content :: LBS.ByteString
|
||||
content = file ^. _pureFileContent . _Just
|
||||
isLatin = either (const False) (all isLatin1) $ decodeUtf8' content
|
||||
_partEncoding .= bool Base64 QuotedPrintableText isLatin
|
||||
_partContent .= PartContent content
|
||||
forM_ (file ^. _FileReference . _1 . _fileReferenceContent) $ \fRefContent ->
|
||||
replaceMailHeader (CI.original hETag) . Just . decodeUtf8 . toHeader $ etagFileReference # fRefContent
|
||||
replaceMailHeader (CI.original hLastModified) . Just . pack . formatTime defaultTimeLocale rfc822DateFormat $ utcToZonedTime utc fileModified
|
||||
|
||||
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
|
||||
type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
|
||||
toMailPart act = do
|
||||
|
||||
@ -23,3 +23,4 @@ import Model.Types.Markup as Types
|
||||
import Model.Types.Room as Types
|
||||
import Model.Types.Csv as Types
|
||||
import Model.Types.Upload as Types
|
||||
import Model.Types.Communication as Types
|
||||
|
||||
21
src/Model/Types/Communication.hs
Normal file
21
src/Model/Types/Communication.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Model.Types.Communication
|
||||
( CommunicationContent(..), _ccSubject, _ccBody, _ccAttachments
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.File
|
||||
|
||||
import Utils.Lens.TH
|
||||
|
||||
|
||||
data CommunicationContent = CommunicationContent
|
||||
{ ccSubject :: Maybe Text
|
||||
, ccBody :: Html
|
||||
, ccAttachments :: Set FileReference
|
||||
} deriving stock (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
deriving anyclass (Hashable, NFData)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''CommunicationContent
|
||||
makeLenses_ ''CommunicationContent
|
||||
@ -18,7 +18,24 @@ module Model.Types.File
|
||||
, _fieldIdent, _fieldUnpackZips, _fieldMultiple, _fieldRestrictExtensions, _fieldAdditionalFiles, _fieldMaxFileSize
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON, Proxy(..))
|
||||
import Crypto.Hash (Digest, SHA3_512)
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Data.Binary (Binary)
|
||||
import Crypto.Hash.Instances ()
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Control.Lens
|
||||
import Utils.HttpConditional
|
||||
import Data.Binary.Instances.Time ()
|
||||
import Data.Time.Clock.Instances ()
|
||||
import Data.Aeson.TH
|
||||
import Utils
|
||||
import Data.Kind (Type)
|
||||
import Data.Universe
|
||||
import Numeric.Natural
|
||||
import Network.Mime
|
||||
import Control.Monad.Morph
|
||||
import Data.NonNull.Instances ()
|
||||
|
||||
import Database.Persist.Sql (PersistFieldSql(..))
|
||||
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
|
||||
@ -204,7 +221,6 @@ instance HasFileReference FileReference where
|
||||
instance HasFileReference PureFile where
|
||||
newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
_FileReference = iso toFileReference fromFileReference
|
||||
@ -293,7 +309,7 @@ data FileField fileid = FileField
|
||||
, fieldUnpackZips :: FileFieldUserOption Bool
|
||||
, fieldMultiple :: Bool
|
||||
, fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
|
||||
, fieldMaxFileSize :: Maybe Natural
|
||||
, fieldMaxFileSize, fieldMaxCumulativeSize :: Maybe Natural
|
||||
, fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool)
|
||||
, fieldAllEmptyOk :: Bool
|
||||
}
|
||||
@ -311,6 +327,7 @@ instance ToJSON (FileField FileReference) where
|
||||
, pure $ "multiple" JSON..= fieldMultiple
|
||||
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
|
||||
, pure $ "max-file-size" JSON..= fieldMaxFileSize
|
||||
, pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize
|
||||
, pure $ "additional-files" JSON..= addFiles'
|
||||
, pure $ "all-empty-ok" JSON..= fieldAllEmptyOk
|
||||
]
|
||||
@ -326,6 +343,7 @@ instance FromJSON (FileField FileReference) where
|
||||
fieldMultiple <- o JSON..: "multiple"
|
||||
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
||||
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
||||
fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-size"
|
||||
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
||||
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
||||
fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do
|
||||
|
||||
@ -226,6 +226,8 @@ data AppSettings = AppSettings
|
||||
, appVolatileClusterSettingsCacheTime :: DiffTime
|
||||
|
||||
, appJobMaxFlush :: Maybe Natural
|
||||
|
||||
, appCommunicationAttachmentsMaxSize :: Maybe Natural
|
||||
} deriving Show
|
||||
|
||||
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
|
||||
@ -693,6 +695,8 @@ instance FromJSON AppSettings where
|
||||
|
||||
appJobMaxFlush <- o .:? "job-max-flush"
|
||||
|
||||
appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size"
|
||||
|
||||
return AppSettings{..}
|
||||
where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
|
||||
|
||||
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
An Kurs- und Tutoriumsmitteilungen können nun Dateien angehängt werden.
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Course- and tutorial messages (emails) may now carry attached files.
|
||||
@ -4,4 +4,4 @@ $newline never
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<body>
|
||||
#{jMailContent}
|
||||
#{ccBody}
|
||||
|
||||
@ -33,7 +33,7 @@ $if not (null fileInfos)
|
||||
<div .file-uploads-label>_{MsgUtilAddMoreFiles}
|
||||
|
||||
$# new files
|
||||
<input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required :is _Just fieldMaxFileSize:data-max-size=#{maybe "-1" tshow fieldMaxFileSize}>
|
||||
<input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required :is _Just fieldMaxFileSize || is _Just fieldMaxCumulativeSize:data-max-size=#{maybe "-1" tshow (ignoreNothing min fieldMaxFileSize fieldMaxCumulativeSize)}>
|
||||
|
||||
$if fieldMultiple
|
||||
<div .file-input__info>
|
||||
@ -57,6 +57,10 @@ $maybe maxSize <- fieldMaxFileSize
|
||||
$else
|
||||
_{MsgFileUploadMaxSize (textBytes maxSize)}
|
||||
|
||||
$maybe maxSize <- fieldMaxCumulativeSize
|
||||
<div .file-input__info>
|
||||
_{MsgFileUploadCumulativeMaxSize (textBytes maxSize)}
|
||||
|
||||
$if not (fieldOptionForce fieldUnpackZips)
|
||||
<div .file-input__unpack>
|
||||
^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}
|
||||
|
||||
Reference in New Issue
Block a user