fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into feat/tokens

Browse Source
This commit is contained in:
Gregor Kleen 2019-04-10 09:16:49 +02:00
commit 41f228aaad
16 changed files with 57 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

@ -521,6 +521,7 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@ -595,6 +596,7 @@ HelpAnswer: Antworten an
HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym)
HelpEmail: E-Mail
HelpSubject: Betreff
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.

3
package.yaml
View File

@ -220,6 +220,9 @@ executables:
dependencies:
- uniworx
other-modules: []
when:
- condition: flag(library-only)
buildable: false
# Test suite
tests:

7
src/Foundation.hs
View File

@ -2306,12 +2306,9 @@ instance YesodMail UniWorX where
mailT ctx mail = defMailT ctx $ do
void setMailObjectId
setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
ret <- mail
setMailSmtpData
return ret
mail <* setMailSmtpData
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

31
src/Handler/Help.hs
View File

@ -16,16 +16,18 @@ nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
data HelpForm = HelpForm
{ hfReferer:: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfRequest:: Text
{ hfReferer :: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfSubject :: Maybe Text
, hfRequest :: Text
}
helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mReferer mUid = HelpForm
helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mr mReferer mUid = HelpForm
<$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
<*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
<*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing)
where
identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
identActions = Map.fromList $ case mUid of
@ -33,7 +35,7 @@ helpForm mReferer mUid = HelpForm
Nothing -> defaultActions
defaultActions =
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
, (HIAnonymous, pure $ Left Nothing)
]
@ -43,19 +45,16 @@ postHelpR = do
mUid <- maybeAuthId
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
isModal <- hasCustomHeader HeaderIsModal
MsgRenderer mr <- getMsgRenderer
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
let form = wrapForm formWidget def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
formResultModal res HelpR $ \HelpForm{..} -> do
now <- liftIO getCurrentTime
hfReferer' <- traverse toTextUrl hfReferer
queueJob' JobHelpRequest
{ jSender = hfUserId
, jHelpSubject = hfSubject
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer'
@ -64,4 +63,8 @@ postHelpR = do
defaultLayout $ do
setTitleI MsgHelpTitle
$(widgetFile "help")
wrapForm $(widgetFile "help") def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}

8
src/Jobs/Handler/HelpRequest.hs
View File

@ -16,10 +16,11 @@ import Data.Bitraversable
dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> UTCTime
-> Maybe Text -- ^ Help Subject
-> Text -- ^ Help Request
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let userAddress = either
@ -28,8 +29,9 @@ dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
userInfo
mailT def $ do
_mailTo .= [supportAddress]
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
setSubjectI MsgMailSubjectSupport
whenIsJust userAddress (_mailFrom .=)
replaceMailHeader "Auto-Submitted" $ Just "no"
setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
setDate jRequestTime
rtime <- formatTimeMail SelFormatDateTime jRequestTime
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

1
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -23,6 +23,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

1
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs
View File

@ -19,6 +19,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

1
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -18,6 +18,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

2
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -21,6 +21,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
@ -47,6 +48,7 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
-- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser
return (E.countRows :: E.SqlExpr (E.Value Int64))
return (course, sheet, nrSubs, nrSubmitters)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

1
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -23,6 +23,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
course <- belongsToJust sheetCourse sheet
corrector <- traverse getJust submissionRatingBy
return (course, sheet, submission, corrector)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
csid <- encrypt nSubmission

1
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -20,6 +20,7 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser
lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
return (user,adminSchools,lecturerSchools)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
-- MsgRenderer mr <- getMailMsgRenderer
editNotifications <- mkEditNotifications jRecipient

1
src/Jobs/Handler/SendTestEmail.hs
View File

@ -13,6 +13,7 @@ import Utils.Lens
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailTestSubject
now <- liftIO getCurrentTime
nDT <- formatTimeMail SelFormatDateTime now

5
src/Jobs/Types.hs
View File

@ -17,7 +17,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
, jHelpSubject :: Maybe Text
, jHelpRequest :: Text
, jReferer :: Maybe Text
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)

16
src/Mail.hs
View File

@ -27,7 +27,7 @@ module Mail
, setSubjectI, setMailObjectId, setMailObjectId'
, setDate, setDateCurrent
, setMailSmtpData
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
) where
@ -99,9 +99,18 @@ import Data.Universe.Instances.Reverse.Hashable ()
import GHC.Exts (IsList)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
makeLenses_ ''Mail
makeLenses_ ''Part
_mailHeader :: CI ByteString -> Traversal' Mail Text
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
@ -443,7 +452,10 @@ setDate time = do
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setMailSmtpData = do
Address _ from <- use _mailFrom
Just (Address _ from) <- runMaybeT $ asum
[ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
, use _mailFrom
]
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
tell $ mempty { smtpRecipients = recps }

2
templates/help.hamlet
View File

@ -1,3 +1,3 @@
<p>
_{MsgHelpIntroduction}
^{form}
^{formWidget}

2
test.sh
View File

@ -11,4 +11,4 @@ if [[ -d .stack-work-test ]]; then
trap move-back EXIT
fi
exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}
exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}