diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8ccff193a..3857ee525 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -65,8 +65,8 @@ CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. -CourseRegisterOk: Sie wurden angemeldet -CourseDeregisterOk: Sie wurden abgemeldet +CourseRegisterOk: Anmeldung erfolgreich +CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort @@ -112,6 +112,9 @@ CourseUserNote: Notiz CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht +CourseUserDeregister: Abmelden +CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet + CourseLecturers: Kursverwalter CourseLecturer: Dozent CourseAssistant: Assistent @@ -273,6 +276,9 @@ DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen +HomeOpenCourses: Kurse mit offener Registrierung +HomeUpcomingSheets: Anstehende Übungsblätter + NumCourses num@Int64: #{display num} Kurse CloseAlert: Schliessen @@ -507,6 +513,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 @@ -581,6 +588,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. diff --git a/package.yaml b/package.yaml index 339ecff3e..c2a1ebf61 100644 --- a/package.yaml +++ b/package.yaml @@ -218,6 +218,9 @@ executables: dependencies: - uniworx other-modules: [] + when: + - condition: flag(library-only) + buildable: false # Test suite tests: diff --git a/routes b/routes index f76fd47b7..d558de967 100644 --- a/routes +++ b/routes @@ -75,7 +75,7 @@ /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST /delete CDeleteR GET POST !lecturerANDempty - /users CUsersR GET + /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /notes CNotesR GET POST !corrector diff --git a/shell.nix b/shell.nix index e6178f7b0..f98506e41 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" diff --git a/src/Application.hs b/src/Application.hs index 1dd037aba..20824d216 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -76,6 +76,8 @@ import qualified Database.Memcached.Binary.IO as Memcached -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common import Handler.Home +import Handler.Info +import Handler.Help import Handler.Profile import Handler.Users import Handler.Admin diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 76f12ce89..2131bf527 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -66,7 +66,7 @@ campusForm :: ( RenderMessage site FormMessage , Button site ButtonSubmit ) => AForm (HandlerT site IO) CampusLogin campusForm = CampusLogin - <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing + <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing campusLogin :: forall site. @@ -88,9 +88,14 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} FormMissing -> redirect LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do ldapResult <- withLdap pool $ \ldap -> do - Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) Ldap.bind ldap ldapDn ldapPassword - findUser conf ldap campusIdent [userPrincipalName] + searchResults <- findUser conf ldap campusIdent [userPrincipalName] + case searchResults of + [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] + | Just [principalName] <- lookup userPrincipalName userAttrs + , Right credsIdent <- Text.decodeUtf8' principalName + -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) + other -> return $ Left other case ldapResult of Left err | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err @@ -100,16 +105,11 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} | otherwise -> do $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError - Right searchResults - | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults - , Just [principalName] <- lookup userPrincipalName userAttrs - , Right credsIdent <- Text.decodeUtf8' principalName - -> do - $logDebugS "LDAP" $ tshow searchResults - lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] - | otherwise -> do - $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults - loginErrorMessageI LoginR Msg.AuthError + Right (Right (userDN, credsIdent)) -> + lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + Right (Left searchResults) -> do + $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults + loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs new file mode 100644 index 000000000..f151b6c18 --- /dev/null +++ b/src/Data/List/NonEmpty/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.List.NonEmpty.Instances + ( + ) where + +import Data.List.NonEmpty + +import Language.Haskell.TH.Syntax (Lift(..)) + +instance Lift a => Lift (NonEmpty a) where + lift (toList -> xs) = [e|fromList xs|] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f3aec73aa..6c89e6c96 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -5,8 +5,9 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , any, all , SqlIn(..) - , mkExactFilter, mkContainsFilter - , anyFilter + , mkExactFilter, mkExactFilterWith + , mkContainsFilter + , anyFilter, allFilter ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) @@ -74,13 +75,22 @@ _queryFeaturesDegree = $(sqlIJproj 3 2) -- Given a lens-like function, make filter for exact matches in a collection -- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere) mkExactFilter :: (PersistField a) - => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection -> E.SqlExpr (E.Value Bool) -mkExactFilter lenslike row criterias +mkExactFilter = mkExactFilterWith id + +-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ +mkExactFilterWith :: (PersistField b) + => (a -> b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias) + | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements @@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias - -anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) - -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) +-- | Combine several filters, using logical or +anyFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) anyFilter fltrs needle criterias = F.foldr aux false fltrs where - aux fltr acc = fltr needle criterias E.||. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.||. acc + +-- | Combine several filters, using logical and +allFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +allFilter fltrs needle criterias = F.foldr aux true fltrs + where + aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 70155f9a4..b645b5fa1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2223,12 +2223,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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 653f91979..4e4b07eee 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -305,7 +305,6 @@ postAdminFeaturesR = do unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant let newKeys = map (StudyTermsKey' . fst) infAccepted setSessionJson sessionKeyNewStudyTerms newKeys - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise @@ -324,7 +323,6 @@ postAdminFeaturesR = do _other -> runDB Candidates.conflicts newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable)) <- runDB $ (,,) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9381e0829..42c21d62a 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -161,6 +161,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E mkRoute = do cid <- encrypt subId return $ CSubmissionR tid ssh csh sheetName cid CorrectionR + mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this in mconcat [ anchorCellM mkRoute $(widgetFile "widgets/rating/rating") , writerCell $ do diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fd7ae019e..98016ca8e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -14,6 +14,7 @@ import Handler.Utils.Delete import Handler.Utils.Database import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns +import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -705,7 +706,7 @@ validateCourse CourseForm{..} = do uid <- liftHandlerT requireAuthId userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route MsgRenderer mr <- getMsgRenderer - + return [ mr msg | (False, msg) <- [ @@ -819,57 +820,100 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget -makeCourseUserTable cid colChoices psValidator = - -- -- psValidator has default sorting and filtering - let dbtIdent = "courseUsers" :: Text - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery = userTableQuery cid - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) - dbtColonnade = colChoices - dbtSorting = Map.fromList - [ sortUserNameLink queryUser -- slower sorting through clicking name column header - , sortUserSurname queryUser -- needed for initial sorting - , sortUserDisplayName queryUser -- needed for initial sorting - , sortUserEmail queryUser - , sortUserMatriclenr queryUser - , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) - , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date - E.sub_select . E.from $ \edit -> do - E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) - return . E.max_ $ edit E.^. CourseUserNoteEditTime - ) - ] - dbtFilter = Map.fromList - [ fltrUserNameLink queryUser - , fltrUserEmail queryUser - , fltrUserMatriclenr queryUser - , fltrUserNameEmail queryUser - -- , ("course-user-degree", error "TODO") -- TODO - -- , ("course-user-field" , error "TODO") -- TODO - , ("course-user-semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - -- , ("course-registration", error "TODO") -- TODO - -- , ("course-user-note", error "TODO") -- TODO - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - ] - dbtParams = def - in dbTableWidget' psValidator DBTable{..} +data CourseUserAction = CourseUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCUsersR tid ssh csh = do - (course, numParticipants, participantTable) <- runDB $ do +instance Universe CourseUserAction +instance Finite CourseUserAction +nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''CourseUserAction id + +makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget) +makeCourseUserTable cid colChoices psValidator = do + Just currentRoute <- liftHandlerT getCurrentRoute + -- -- psValidator has default sorting and filtering + let dbtIdent = "courseUsers" :: Text + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtSQLQuery = userTableQuery cid + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) + dbtColonnade = colChoices + dbtSorting = Map.fromList + [ sortUserNameLink queryUser -- slower sorting through clicking name column header + , sortUserSurname queryUser -- needed for initial sorting + , sortUserDisplayName queryUser -- needed for initial sorting + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) + , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) + , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) + , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date + E.sub_select . E.from $ \edit -> do + E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) + return . E.max_ $ edit E.^. CourseUserNoteEditTime + ) + ] + dbtFilter = Map.fromList + [ fltrUserNameLink queryUser + , fltrUserEmail queryUser + , fltrUserMatriclenr queryUser + , fltrUserNameEmail queryUser + , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) + , ("field" , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) + , E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) + ] ) + , ("degree" , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) + , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) + ] ) + , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + -- , ("course-registration", error "TODO") -- TODO + -- , ("course-user-note", error "TODO") -- TODO + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) + , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + (res,vw) <- mreq (selectField optionsFinite) "" Nothing + let formWgt = toWidget csrf <> fvInput vw + formRes = (, mempty) . First . Just <$> res + return (formRes,formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + over _1 postprocess <$> dbTable psValidator DBTable{..} + where + postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) + +getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCUsersR = postCUsersR +postCUsersR tid ssh csh = do + (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do let colChoices = mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr , colUserDegreeShort @@ -879,10 +923,18 @@ getCUsersR tid ssh csh = do , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName - Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh + ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - participantTable <- makeCourseUserTable cid colChoices psValidator - return (course, numParticipants, participantTable) + table <- makeCourseUserTable cid colChoices psValidator + return (ent, numParticipants, table) + formResult participantRes $ \case + (CourseUserDeregister,selectedUsers) -> do + nrDel <- runDB $ deleteWhereCount + [ CourseParticipantCourse ==. cid + , CourseParticipantUser <-. Set.toList selectedUsers + ] + addMessageI Success $ MsgCourseUsersDeregistered nrDel + redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs new file mode 100644 index 000000000..d29b7f214 --- /dev/null +++ b/src/Handler/Help.hs @@ -0,0 +1,70 @@ +module Handler.Help where + +import Import +import Handler.Utils +import Jobs + +import qualified Data.Map as Map + +data HelpIdentOptions = HIUser | HIEmail | HIAnonymous + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance Universe HelpIdentOptions +instance Finite HelpIdentOptions + +nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) +embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") + +data HelpForm = HelpForm + { hfReferer :: Maybe (Route UniWorX) + , hfUserId :: Either (Maybe Address) UserId + , hfSubject :: Maybe Text + , hfRequest :: Text + } + +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) + <*> 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 + (Just uid) -> (HIUser, pure $ Right uid):defaultActions + Nothing -> defaultActions + + defaultActions = + [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing)) + , (HIAnonymous, pure $ Left Nothing) + ] + +getHelpR, postHelpR :: Handler Html +getHelpR = postHelpR +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 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' + } + tell . pure =<< messageI Success MsgHelpSent + + defaultLayout $ do + setTitleI MsgHelpTitle + wrapForm $(widgetFile "help") def + { formAction = Just $ SomeRoute HelpR + , formEncoding = formEnctype + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 81dc1ac66..81d9f7066 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,23 +4,20 @@ import Import import Handler.Utils import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Database.Esqueleto as E -import Jobs -import Development.GitRev - getHomeR :: Handler Html getHomeR = do muid <- maybeAuthId - case muid of - Nothing -> homeAnonymous - Just uid -> homeUser uid + defaultLayout $ do + setTitleI MsgHomeHeading + maybe mempty homeUpcomingSheets muid + homeOpenCourses -homeAnonymous :: Handler Html -homeAnonymous = do +homeOpenCourses :: Widget +homeOpenCourses = do cTime <- liftIO getCurrentTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) @@ -47,7 +44,7 @@ homeAnonymous = do , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- runDB $ dbTableWidget' def DBTable + courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable { dbtSQLQuery = tableData , dbtRowKey = (E.^. CourseId) , dbtColonnade = colonnade @@ -75,16 +72,12 @@ homeAnonymous = do , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "open-courses" :: Text } - -- let features = $(widgetFile "featureList") - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" - defaultLayout - -- (widgetFile "dsgvDisclaimer") - $(widgetFile "home") + $(widgetFile "home/openCourses") -homeUser :: Key User -> Handler Html -homeUser uid = do +homeUpcomingSheets :: UserId -> Widget +homeUpcomingSheets uid = do cTime <- liftIO getCurrentTime let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) @@ -140,7 +133,7 @@ homeUser uid = do (toWidget $ hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] - sheetTable <- runDB $ dbTableWidget' validator DBTable + sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade @@ -175,155 +168,6 @@ homeUser uid = do , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "upcoming-sheets" :: Text } - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." - defaultLayout $ - -- setTitle "Willkommen zum Uni2work Test!" - $(widgetFile "homeUser") - -- (widgetFile "dsgvDisclaimer") - --- | Versionsgeschichte -getVersionR :: Handler TypedContent -getVersionR = getInfoR -- TODO - --- | Impressum -getImpressumR :: Handler Html -getImpressumR = -- do - siteLayoutMsg' MsgMenuImpressum $ do - setTitleI MsgImpressumHeading - $(i18nWidgetFile "imprint") - - --- | Hinweise zu Datenschutz und Aufbewahrungspflichten -getDataProtR :: Handler Html -getDataProtR = -- do - siteLayoutMsg' MsgMenuDataProt $ do - setTitleI MsgDataProtHeading - $(i18nWidgetFile "data-protection") - - --- | Allgemeine Informationen -getInfoR :: Handler TypedContent -getInfoR = selectRep $ do - let infoHeading = [whamlet|Re-Implementierung von UniWorX|] - provideRep . siteLayout infoHeading $ do - let features = $(widgetFile "featureList") - gitInfo :: Text - gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" - changeLog <- withUrlRenderer $(textFile "ChangeLog.md") - $(widgetFile "versionHistory") - provideRep $ - return ($gitDescribe :: Text) - - - - -data HelpIdentOptions = HIUser | HIEmail | HIAnonymous - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance Universe HelpIdentOptions -instance Finite HelpIdentOptions - -nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) -embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") - -data HelpForm = HelpForm - { hfReferer:: Maybe (Route UniWorX) - , hfUserId :: Either (Maybe Address) UserId - , hfRequest:: Text - } - -helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm -helpForm mReferer mUid = HelpForm - <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) - <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) - where - identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) - identActions = Map.fromList $ case mUid of - (Just uid) -> (HIUser, pure $ Right uid):defaultActions - Nothing -> defaultActions - - defaultActions = - [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) - , (HIAnonymous, pure $ Left Nothing) - ] - -getHelpR, postHelpR :: Handler Html -getHelpR = postHelpR -postHelpR = do - mUid <- maybeAuthId - mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) - isModal <- hasCustomHeader HeaderIsModal - - ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid - let form = wrapForm formWidget def - { formAction = Just $ SomeRoute HelpR - , formEncoding = formEnctype - , formAttrs = [ ("uw-async-form", "") | isModal ] - } - - formResultModal res HelpR $ \HelpForm{..} -> do - now <- liftIO getCurrentTime - hfReferer' <- traverse toTextUrl hfReferer - queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpRequest = hfRequest - , jRequestTime = now - , jReferer = hfReferer' - } - tell . pure =<< messageI Success MsgHelpSent - - defaultLayout $ do - setTitleI MsgHelpTitle - $(widgetFile "help") - - -getInfoLecturerR :: Handler Html -getInfoLecturerR = - siteLayoutMsg' MsgInfoLecturerTitle $ do - setTitleI MsgInfoLecturerTitle - $(i18nWidgetFile "info-lecturer") - - -getAuthPredsR, postAuthPredsR :: Handler Html -getAuthPredsR = postAuthPredsR -postAuthPredsR = do - (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - - let - blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ] - taForm authTag - | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag) - | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) - - ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard - $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True - - mReferer <- runMaybeT $ do - param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) - MaybeT . return $ fromPathPiece param - - let authActiveForm = wrapForm authActiveWidget' def - { formAction = Just $ SomeRoute AuthPredsR - , formEncoding = authActiveEnctype - , formSubmit = FormDualSubmit - } - authActiveWidget' - = [whamlet| - $newline never - $maybe referer <- mReferer - - ^{authActiveWidget} - |] - - formResult authActiveRes $ \authTagActive -> do - setSessionJson SessionActiveAuthTags authTagActive - modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) - addMessageI Success MsgAuthPredsActiveChanged - redirect $ fromMaybe AuthPredsR mReferer - - siteLayoutMsg MsgAuthPredsActive $ do - setTitleI MsgAuthPredsActive - $(widgetFile "authpreds") + $(widgetFile "home/upcomingSheets") \ No newline at end of file diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs new file mode 100644 index 000000000..9790ed143 --- /dev/null +++ b/src/Handler/Info.hs @@ -0,0 +1,48 @@ +module Handler.Info where + +import Import +import Handler.Utils + +import Development.GitRev + +-- | Versionsgeschichte +getVersionR :: Handler TypedContent +getVersionR = selectRep $ do + provideRep $ + return ($gitDescribe :: Text) + provideRep getInfoR + +-- | Impressum +getImpressumR :: Handler Html +getImpressumR = -- do + siteLayoutMsg' MsgMenuImpressum $ do + setTitleI MsgImpressumHeading + $(i18nWidgetFile "imprint") + + +-- | Hinweise zu Datenschutz und Aufbewahrungspflichten +getDataProtR :: Handler Html +getDataProtR = -- do + siteLayoutMsg' MsgMenuDataProt $ do + setTitleI MsgDataProtHeading + $(i18nWidgetFile "data-protection") + + +-- | Allgemeine Informationen +getInfoR :: Handler Html +getInfoR = do + let infoHeading = [whamlet|Re-Implementierung von UniWorX|] + siteLayout infoHeading $ do + let features = $(widgetFile "featureList") + gitInfo :: Text + gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" + changeLog <- withUrlRenderer $(textFile "ChangeLog.md") + $(widgetFile "versionHistory") + + +getInfoLecturerR :: Handler Html +getInfoLecturerR = + siteLayoutMsg' MsgInfoLecturerTitle $ do + setTitleI MsgInfoLecturerTitle + $(i18nWidgetFile "info-lecturer") + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d582abf41..5de418a34 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -10,7 +10,7 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -491,3 +491,44 @@ mkCorrectionsTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} + +getAuthPredsR, postAuthPredsR :: Handler Html +getAuthPredsR = postAuthPredsR +postAuthPredsR = do + (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + + let + blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ] + taForm authTag + | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag) + | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) + + ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard + $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True + + mReferer <- runMaybeT $ do + param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) + MaybeT . return $ fromPathPiece param + + let authActiveForm = wrapForm authActiveWidget' def + { formAction = Just $ SomeRoute AuthPredsR + , formEncoding = authActiveEnctype + , formSubmit = FormDualSubmit + } + authActiveWidget' + = [whamlet| + $newline never + $maybe referer <- mReferer + + ^{authActiveWidget} + |] + + formResult authActiveRes $ \authTagActive -> do + setSessionJson SessionActiveAuthTags authTagActive + modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) + addMessageI Success MsgAuthPredsActiveChanged + redirect $ fromMaybe AuthPredsR mReferer + + siteLayoutMsg MsgAuthPredsActive $ do + setTitleI MsgAuthPredsActive + $(widgetFile "authpreds") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 7faa02e29..cc5bc7718 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -199,11 +199,12 @@ getSheetListR tid ssh csh = do let stats = sheetTypeSum sheetType in -- for statistics over all shown rows case mbSub of Nothing -> cellTell mempty $ stats Nothing - (Just (Entity sid Submission{..})) -> + (Just (Entity sid sub@Submission{..})) -> let mkCid = encrypt sid mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR + mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") in cellTell acell $ stats submissionRatingPoints diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 7683950d1..46abeddd5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -10,7 +10,8 @@ import qualified Data.Set as Set import Data.CaseInsensitive (original) -- import qualified Data.CaseInsensitive as CI -import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qRunIO) -- import Language.Haskell.TH.Datatype import Text.Hamlet (shamletFile) @@ -26,6 +27,12 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils +import System.Directory (listDirectory) +import System.FilePath.Posix (takeBaseName) + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty + downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do @@ -135,11 +142,30 @@ warnTermDays tid times = do forM_ outoftermdays $ warnI MsgDayIsOutOfTerm -- | Add language dependent template files --- For large files which are translated as a whole. --- Argument musst be a directory under templates, --- which contains a file for each language, --- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet +-- +-- For large files which are translated as a whole. +-- +-- Argument musst be a directory under @/templates@, +-- which contains a file for each language, +-- eg. @imprint@ for choosing between +-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@, +-- and @/templates/imprint/en.hamlet@ +-- +-- Dependency detection cannot work properly (no `addDependentFile`-equivalent +-- for directories) +-- @$ stack clean@ is required so new translations show up i18nWidgetFile :: FilePath -> Q Exp -i18nWidgetFile = - -- TODO write code to distinguish languages here - widgetFile . ( "de") +i18nWidgetFile basename = do + -- Construct list of available translations (@de@, @en@, ...) at compile time + let i18nDirectory = "templates" basename + availableFiles <- qRunIO $ listDirectory i18nDirectory + let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles + availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations + + -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time + ws <- newName "ws" -- Name for dispatch function + letE + [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename l) [] + | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language + ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match + ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 124da1b83..67c8fab75 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -462,10 +462,10 @@ sinkSubmission userId mExists isUpdate = do case isUpdate of False -> lift . insert_ $ SubmissionEdit userId now submissionId True -> do - Submission{submissionRatingTime} <- lift $ getJust submissionId - when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } - lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] - -- TODO: Should submissionRatingAssigned change here if userId changes? + Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId + when (submissionRatingBy == Just userId) $ do + when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } + lift $ update submissionId [ SubmissionRatingTime =. Just now ] tellSt $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodJobDB UniWorX () diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index dd0861ab9..457682087 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -42,7 +42,8 @@ import GHC.Exts as Import (IsList) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) -import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.List.NonEmpty.Instances as Import () +import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) import Data.Monoid as Import (Last(..), First(..)) import Data.Monoid.Instances as Import () diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 1ec904e2b..2b92c0e2b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -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 <- getsYesod $ appMailSupport . appSettings 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)) diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 51ec02f77..6a9e6ace9 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -22,6 +22,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 diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index cb24f7e04..959cedad0 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index 91a8fc716..fc2c5a185 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -17,6 +17,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 diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 7112e5c39..ed76be1b3 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -20,6 +20,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 @@ -45,6 +46,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 diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 78083d83f..1cb3e1d50 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -22,6 +22,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 diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index aaf50ac72..3e9d2c4a8 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -19,6 +19,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 addAlternatives $ do diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 5c5cd0900..979ec218d 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 151d0e404..dc29a9e7a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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) diff --git a/src/Mail.hs b/src/Mail.hs index c125bf88d..008af9987 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -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 } diff --git a/templates/help.hamlet b/templates/help.hamlet index 4e1beb4cd..073bac477 100644 --- a/templates/help.hamlet +++ b/templates/help.hamlet @@ -1,3 +1,3 @@

_{MsgHelpIntroduction} -^{form} +^{formWidget} diff --git a/templates/home.hamlet b/templates/home.hamlet deleted file mode 100644 index 3995b864f..000000000 --- a/templates/home.hamlet +++ /dev/null @@ -1,5 +0,0 @@ -

-

- Kurse mit offener Registrierung -
- ^{courseTable} diff --git a/templates/home/openCourses.hamlet b/templates/home/openCourses.hamlet new file mode 100644 index 000000000..d578cf404 --- /dev/null +++ b/templates/home/openCourses.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeOpenCourses} + ^{courseTable} diff --git a/templates/home/upcomingSheets.hamlet b/templates/home/upcomingSheets.hamlet new file mode 100644 index 000000000..d109294c9 --- /dev/null +++ b/templates/home/upcomingSheets.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeUpcomingSheets} + ^{sheetTable} diff --git a/templates/homeUser.hamlet b/templates/homeUser.hamlet deleted file mode 100644 index 479d27ab9..000000000 --- a/templates/homeUser.hamlet +++ /dev/null @@ -1,17 +0,0 @@ -
-

- Anstehende Übungsblätter -
- ^{sheetTable} - - diff --git a/templates/widgets/rating/rating.hamlet b/templates/widgets/rating/rating.hamlet index 5c42595e2..a2fb74fe0 100644 --- a/templates/widgets/rating/rating.hamlet +++ b/templates/widgets/rating/rating.hamlet @@ -1,8 +1,10 @@ $# Display Rating, expects +$# sub :: Submission +$# submissionRatingDone :: Submission -> Bool $# submissionRatingPoints :: Maybe points -$maybe points <- submissionRatingPoints - $maybe grading <- preview _grading sheetType +$if submissionRatingDone sub + $maybe (grading, points) <- mTuple (preview _grading sheetType) submissionRatingPoints $case grading $of Points{..} _{MsgAchievedOf points maxPoints} diff --git a/test.sh b/test.sh index 09d4b3a53..7db64f3c6 100755 --- a/test.sh +++ b/test.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -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 ${@}