module Handler.Profile ( getProfileR, postProfileR , getForProfileR, postForProfileR , getProfileDataR, makeProfileData , getForProfileDataR , getAuthPredsR, postAuthPredsR , getUserNotificationR, postUserNotificationR , getSetDisplayEmailR, postSetDisplayEmailR , getCsvOptionsR, postCsvOptionsR , postLangR ) where import Import import Handler.Utils import Handler.Utils.Profile import Utils.Print (validCmdArgument) -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto ((^.)) import qualified Data.Text as Text import Data.List (inits) import qualified Data.CaseInsensitive as CI import Jobs import Foundation.Yesod.Auth (updateUserLanguage) data ExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced :: Bool , eosettingsGetLabels :: Bool , eosettingsLabels :: EOLabels } type EOLabelData = ( ExamOfficeLabelName , MessageStatus -- status , Int -- priority; also used for label ordering ) type EOLabels = Map (Either ExamOfficeLabelName ExamOfficeLabelId) EOLabelData data SettingsForm = SettingsForm { stgDisplayName :: UserDisplayName , stgDisplayEmail :: UserEmail , stgMaxFavourites :: Int , stgMaxFavouriteTerms :: Int , stgTheme :: Theme , stgDateTime :: DateTimeFormat , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool , stgWarningDays :: NominalDiffTime , stgShowSex :: Bool , stgPinPassword :: Text , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool) } makeLenses_ ''SettingsForm data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKSubmissionUser | NTKExamParticipant | NTKCorrector | NTKCourseLecturer | NTKAllocationStaff | NTKAllocationParticipant | NTKFunctionary SchoolFunction deriving (Eq, Ord, Generic, Typeable) deriveFinite ''NotificationTriggerKind instance RenderMessage UniWorX NotificationTriggerKind where renderMessage f ls = \case NTKAll -> mr MsgNotificationTriggerKindAll NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant NTKSubmissionUser -> mr MsgNotificationTriggerKindSubmissionUser NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant NTKCorrector -> mr MsgNotificationTriggerKindCorrector NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation NTKFunctionary SchoolAllocation -> mr MsgNotificationTriggerKindAllocationAdmin where mr = renderMessage f ls data AllocationNotificationState = AllocNotifyNewCourseDefault | AllocNotifyNewCourseForceOff | AllocNotifyNewCourseForceOn deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) embedRenderMessage ''UniWorX ''AllocationNotificationState id nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do MsgRenderer mr <- getMsgRenderer (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm <$ aformSection MsgFormPersonalAppearance <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template) <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template) <* aformSection MsgFormCosmetics <*> areq (natFieldI MsgFavouritesNotNatural) (fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template) <*> areq (natFieldI MsgFavouritesSemestersNotNatural) (fslpI MsgFavouriteSemesters (mr MsgFavouritesSemestersPlaceholder)) (stgMaxFavouriteTerms <$> template) <*> areq (selectField . return $ mkOptionList themeList) (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) <* aformSection MsgFormBehaviour <*> apopt checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) <*> areq daysField (fslI MsgWarningDays & setTooltip MsgWarningDaysTip ) (stgWarningDays <$> template) <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications <*> areq (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) <*> apopt checkBoxField (fslI MsgPrefersPostal & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) <*> allocationNotificationForm (stgAllocationNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF] schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty where schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) schoolsForm' = do allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName] let schoolForm (Entity ssh School{schoolName}) = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template) fold <$> mapM schoolForm allSchools schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX]) schoolsFormView (res, fvInput) = do mr <- getMessageRender let fvLabel = toHtml $ mr MsgUserSchools fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip fvRequired = False fvErrors | FormFailure (err : _) <- res = Just $ toHtml err | otherwise = Nothing fvId <- newIdent return (res, pure FieldView{..}) notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do mbUid <- liftHandler maybeAuthId isAdmin <- lift . lift $ hasReadAccessTo AdminR let sectionIsHidden :: NotificationTriggerKind -> DB Bool sectionIsHidden = \case _ | isAdmin -> return False NTKAll -> return False NTKCourseParticipant | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive NTKSubmissionUser | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid NTKExamParticipant | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid NTKCorrector | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid NTKCourseLecturer | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid NTKAllocationStaff | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid NTKAllocationParticipant | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \courseApplication -> E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocation) NTKFunctionary f | Just uid <- mbUid -> fmap not . E.selectExists . E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token) ntHidden <- liftHandler . runDB $ Set.fromList universeF & Map.fromSet sectionIsHidden & sequenceA & fmap (!) let ntfs nt = fslI nt & case nt of NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip _other -> id nsForm nt | maybe False ntHidden $ ntSection nt = pure $ notificationAllowed def nt | nt `elem` forcedTriggers = aforced checkBoxField (ntfs nt) (notificationAllowed def nt) | otherwise = apopt checkBoxField (ntfs nt) (flip notificationAllowed nt <$> template) ntSection = \case NTSubmissionRatedGraded -> Just NTKCourseParticipant NTSubmissionRated -> Just NTKCourseParticipant NTSubmissionUserCreated -> Just NTKCourseParticipant NTSubmissionUserDeleted -> Just NTKSubmissionUser NTSubmissionEdited -> Just NTKSubmissionUser NTSheetActive -> Just NTKCourseParticipant NTSheetHint -> Just NTKCourseParticipant NTSheetSolution -> Just NTKCourseParticipant NTSheetSoonInactive -> Just NTKCourseParticipant NTSheetInactive -> Just NTKCourseLecturer NTCorrectionsAssigned -> Just NTKCorrector NTCorrectionsNotDistributed -> Just NTKCourseLecturer NTUserRightsUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll NTExamRegistrationActive -> Just NTKCourseParticipant NTExamRegistrationSoonInactive -> Just NTKCourseParticipant NTExamDeregistrationSoonInactive -> Just NTKCourseParticipant NTExamResult -> Just NTKExamParticipant NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer NTAllocationAllocation -> Just NTKAllocationStaff NTAllocationRegister -> Just NTKAll NTAllocationOutdatedRatings -> Just NTKAllocationStaff NTAllocationUnratedApplications -> Just NTKAllocationStaff NTAllocationResults -> Just NTKAllocationParticipant NTAllocationNewCourse -> Just NTKAllocationParticipant NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice NTCourseRegistered -> Just NTKAll NTQualification -> Just NTKAll -- _other -> Nothing forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate] aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool)) getAllocationNotifications uid = fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any))) [ getBySettings , getByApplications , getByAllocationUser ] where getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] [] where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation , Just $ not allocationNotificationSettingIsOptOut ) | Entity _ AllocationNotificationSetting{..} <- settings ] getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] [] where toMap applications = Map.fromList [ (alloc, Nothing) | Entity _ CourseApplication{..} <- applications , alloc <- hoistMaybe courseApplicationAllocation ] getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] [] where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing) | Entity _ AllocationUser{..} <- allocsUser ] setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m () setAllocationNotifications allocationNotificationSettingUser allocs = do deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ] void . insertMany $ do (allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt return AllocationNotificationSetting{..} allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<) where allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState _AllocNotify = iso toNotify fromNotify where fromNotify = \case AllocNotifyNewCourseDefault -> Nothing AllocNotifyNewCourseForceOn -> Just True AllocNotifyNewCourseForceOff -> Just False toNotify = \case Nothing -> AllocNotifyNewCourseDefault Just True -> AllocNotifyNewCourseForceOn Just False -> AllocNotifyNewCourseForceOff Allocation{..} <- liftHandler . runDB $ getJust allocId MsgRenderer mr <- getMsgRenderer let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|] cID <- encrypt allocId :: _ CryptoUUIDAllocation fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify) where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair currentRoute <- fromMaybe (error "examOfficeForm called from 404-handler") <$> liftHandler getCurrentRoute mr <- getMessageRender let userExamOfficeLabels :: EOLabels userExamOfficeLabels = maybe mempty eosettingsLabels template eoLabelsForm :: AForm Handler EOLabels eoLabelsForm = wFormToAForm $ do let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId))) ) miAdd _ _ _ nudge submitView = Just $ \csrf -> do (addRes, addView) <- mpreq textField (fslI MsgExamOfficeLabelName & addName (nudge "name")) Nothing let addRes' = addRes <&> \nLabel oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if | Set.member (Left nLabel) . Set.fromList $ Map.elems oldData -> FormFailure [mr MsgExamOfficeLabelAlreadyExists] | otherwise -> FormSuccess $ Map.singleton kStart (Left nLabel) return (addRes', $(widgetFile "profile/exam-office-labels/add")) miCell :: ListPosition -> Either ExamOfficeLabelName ExamOfficeLabelId -> Maybe EOLabelData -> (Text -> Text) -> Form EOLabelData miCell _ eoLabel initRes nudge csrf = do labelIdent <- case eoLabel of Left lblName -> return lblName Right lblId -> do ExamOfficeLabel{examOfficeLabelName} <- liftHandler . runDB $ getJust lblId return examOfficeLabelName (statusRes, statusView) <- mreq (selectField optionsFinite) (fslI MsgExamOfficeLabelStatus & addName (nudge "status")) ((\(_,x,_) -> x) <$> initRes) (priorityRes, priorityView) <- mreq intField (fslI MsgExamOfficeLabelPriority & addName (nudge "priority")) (((\(_,_,x) -> x) <$> initRes) <|> Just 0) let res :: FormResult EOLabelData res = (,,) <$> FormSuccess labelIdent <*> statusRes <*> priorityRes return (res, $(widgetFile "profile/exam-office-labels/cell")) miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete = miDeleteList miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition miAddEmpty _ _ _ = Set.empty miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag miLayout :: ListLength -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget miLayout lLength _ cellWdgts delButtons addWdgets = $(widgetFile "profile/exam-office-labels/layout") miIdent :: Text miIdent = "exam-office-labels" filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData)) filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels fmap (Map.fromList . Map.elems) <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR if userIsExamOffice then aFormToWForm $ ExamOfficeSettings <$ aformSection MsgFormExamOffice <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) <*> eoLabelsForm else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do userDisplayName' <- use _stgDisplayName guardValidation MsgUserDisplayNameInvalid $ userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved) validDisplayName userTitle userFirstName userSurname userDisplayName' userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument userPinPassword' pinMinChar = 5 whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk guardValidation (MsgPDFPasswordTooShort pinMinChar) $ pinMinChar <= length userPinPassword' userPostAddress' <- use _stgPostAddress let postalNotSet = isNothing userPostAddress' postalIsValid = validPostAddress userPostAddress' guardValidation MsgUserPostalInvalid $ postalNotSet || postalIsValid userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ not $ userPrefersPostal' && postalNotSet data ButtonResetTokens = BtnResetTokens deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonResetTokens instance Finite ButtonResetTokens nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonResetTokens id instance Button UniWorX ButtonResetTokens where btnClasses BtnResetTokens = [BCIsButton, BCDanger] data ProfileAnchor = ProfileSettings | ProfileResetTokens deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ProfileAnchor instance Finite ProfileAnchor nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html getForProfileR = postForProfileR postForProfileR cID = do uid <- decrypt cID user <- runDB $ get404 uid serveProfileR (uid, user) getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = requireAuthPair >>= serveProfileR serveProfileR :: (UserId, User) -> Handler Html serveProfileR (uid, user@User{..}) = do (userSchools, userExamOfficeLabels) <- runDB $ do userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \userSchool -> E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId userExamOfficeLabels <- selectList [ ExamOfficeLabelUser ==. uid ] [] return (userSchools, userExamOfficeLabels) allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName , stgDisplayEmail = userDisplayEmail , stgMaxFavourites = userMaxFavourites , stgMaxFavouriteTerms = userMaxFavouriteTerms , stgTheme = userTheme , stgDateTime = userDateTimeFormat , stgDate = userDateFormat , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles , stgSchools = userSchools , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays , stgShowSex = userShowSex , stgPinPassword = fromMaybe "" userPinPassword , stgPostAddress = userPostAddress , stgPrefersPostal = userPrefersPostal , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels , eosettingsLabels = flip foldMap userExamOfficeLabels $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority) } , stgAllocationNotificationSettings = allocs } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate formResult res $ \SettingsForm{..} -> do runDBJobs $ do update uid $ [ UserDisplayName =. stgDisplayName , UserMaxFavourites =. stgMaxFavourites , UserMaxFavouriteTerms =. stgMaxFavouriteTerms , UserTheme =. stgTheme , UserDateTimeFormat =. stgDateTime , UserDateFormat =. stgDate , UserTimeFormat =. stgTime , UserDownloadFiles =. stgDownloadFiles , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex , UserPinPassword =. Just stgPinPassword , UserPostAddress =. stgPostAddress , UserPrefersPostal =. stgPrefersPostal , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] setAllocationNotifications uid stgAllocationNotificationSettings updateFavourites Nothing when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail let symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools) forM_ symDiff $ \ssh -> if | ssh `Set.member` stgSchools -> void $ upsert UserSchool { userSchoolSchool = ssh , userSchoolUser = uid , userSchoolIsOptOut = False } [ UserSchoolIsOptOut =. False ] | otherwise -> void $ upsert UserSchool { userSchoolSchool = ssh , userSchoolUser = uid , userSchoolIsOptOut = True } [ UserSchoolIsOptOut =. True ] let oldExamLabels = userExamOfficeLabels newExamLabels = stgExamOfficeSettings & eosettingsLabels forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $ update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ] delete eolid forM_ (Map.toList newExamLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. } [ ExamOfficeLabelName =. examOfficeLabelName , ExamOfficeLabelStatus =. examOfficeLabelStatus , ExamOfficeLabelPriority =. examOfficeLabelPriority ] Right lblId -> update lblId [ ExamOfficeLabelName =. examOfficeLabelName , ExamOfficeLabelStatus =. examOfficeLabelStatus , ExamOfficeLabelPriority =. examOfficeLabelPriority ] addMessageI Success MsgSettingsUpdate redirect $ ProfileR :#: ProfileSettings ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm formResult tokenRes $ \BtnResetTokens -> do now <- liftIO getCurrentTime runDB $ update uid [ UserTokensIssuedAfter =. Just now ] addMessageI Info MsgTokensResetSuccess redirect $ ProfileR :#: ProfileResetTokens tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do setTitleI MsgProfileTitle let settingsForm = wrapForm formWidget FormSettings { formMethod = POST , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Just ProfileSettings } tokenForm = wrapForm tokenFormWidget FormSettings { formMethod = POST , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens , formEncoding = tokenEnctype , formAttrs = [] , formSubmit = FormNoSubmit , formAnchor = Just ProfileResetTokens } tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") displayNameRules = $(i18nWidgetFile "profile/displayNameRules") $(widgetFile "profile/profile") getProfileDataR :: Handler Html getProfileDataR = do userEnt <- requireAuth dataWidget <- runDB $ makeProfileData userEnt defaultLayout $ do setTitleI MsgHeadingProfileData dataWidget getForProfileDataR :: CryptoUUIDUser -> Handler Html getForProfileDataR cID = do uid <- decrypt cID (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid defaultLayout $ do setTitleI $ MsgHeadingForProfileData $ userDisplayName user dataWidget makeProfileData :: Entity User -> DB Widget makeProfileData (Entity uid User{..}) = do functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId return (studyfeat, studydegree, studyterms) --Tables (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben qualificationsTable <- mkQualificationsTable uid -- Tabelle mit allen Qualifikationen let examTable, ownTutorialTable, tutorialTable :: Widget examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip tutorialTable = i18n MsgPersonalInfoTutorialsWip cID <- encrypt uid mCRoute <- getCurrentRoute showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) let profileRemarks = $(i18nWidgetFile "profile-remarks") return $(widgetFile "profileData") -- | Table listing all courses that the given user is a lecturer for mkOwnedCoursesTable :: UserId -> DB (Bool, Widget) mkOwnedCoursesTable = let dbtIdent = "courseOwnership" :: Text dbtStyle = def withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) withType = id dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid return ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand ) dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId dbtProj = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTableTerm & cellAttrs .~ [("priority","0")]) $ do tid <- view (_dbrOutput . _1) return $ indicatorCell -- return True if one cell is produced here `mappend` termCell tid , sortable (Just "school") (i18nCell MsgTableCourseSchool) $ schoolCell <$> view (_dbrOutput . _1) <*> view (_dbrOutput . _2 ) , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCellCL <$> view _dbrOutput ] validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ] dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) ] dbtFilter = Map.fromList [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} -- | Table listing all courses that the given user is enrolled in mkEnrolledCoursesTable :: UserId -> DB Widget mkEnrolledCoursesTable = let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) withType = id validator = def & defaultSorting [SortDescBy "time"] in \uid -> dbTableWidget' validator DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, participant E.^. CourseParticipantRegistration) , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue , dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTableTerm) $ termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ schoolCell <$> view _courseTerm <*> view _courseSchool , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do regTime <- view $ _dbrOutput . _2 return $ dateTimeCell regTime ] , dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) ] , dbtFilter = Map.fromList [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) , ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] } -- | Table listing all submissions for the given user mkSubmissionTable :: UserId -> DB Widget mkSubmissionTable = let dbtIdent = "submissions" :: Text dbtStyle = def withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) withType = id dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand ) let sht = sheet E.^. SheetName return (crse, sht, submission, lastSubEdit uid submission) dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId lastSubEdit uid submission = -- latest Edit-Time of this user for submission E.subSelectMaybe . E.from $ \subEdit -> do E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid) return . E.max_ $ subEdit E.^. SubmissionEditTime dbtProj = dbtProjId <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) <&> _dbrOutput . _2 %~ E.unValue <&> _dbrOutput . _4 %~ E.unValue dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTableTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view _1 <*> view _2 , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $ sheetCell <$> view _1 <*> view _2 , sortable (toNothingS "submission") (i18nCell MsgTableSubmission) . magnify _dbrOutput $ submissionCell <$> view _1 <*> view _2 <*> view (_3 . _entityKey) -- , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do -- regTime <- view $ _dbrOutput . _4 -- return $ maybe mempty dateTimeCell regTime , sortable (Just "edit") (i18nCell MsgLastEditByUser) $ maybe mempty dateTimeCell <$> view (_dbrOutput . _4) ] validator = def -- DUPLICATED CODE: Handler.Corrections & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") & defaultSorting [SortDescBy "edit"] dbtSorting' uid = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool ) , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName ) , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission ) ] dbtFilter = Map.fromList [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} -- in do dbtSQLQuery <- dbtSQLQuery' -- dbtSorting <- dbtSorting' -- return $ dbTableWidget' validator $ DBTable {..} -- | Table listing all submissions for the given user mkSubmissionGroupTable :: UserId -> DB Widget mkSubmissionGroupTable = let dbtIdent = "subGroups" :: Text dbtStyle = def withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) withType = id dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand ) return (crse, sgroup) dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId dbtProj = dbtProjId <&> _dbrOutput . _1 %~ $(E.unValueN 3) dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTableTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view _1 <*> view _2 , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ cell . views _submissionGroupName toWidget ] validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course"] dbtSorting = Map.fromList [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) , ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName ) ] dbtFilter = Map.fromList [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] dbtFilterUI = mempty dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} mkCorrectionsTable :: UserId -> DB Widget mkCorrectionsTable = let dbtIdent = "corrections" :: Text dbtStyle = def withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) withType = id corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime) dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid let crse = ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand ) return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet)) dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId dbtProj = dbtProjId <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) <&> _dbrOutput . _2 %~ E.unValue dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTableTerm) $ termCellCL <$> view (_dbrOutput . _1) , sortable (Just "school") (i18nCell MsgTableCourseSchool) $ schoolCellCL <$> view (_dbrOutput . _1) , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $ sheetCell <$> view _1 <*> view _2 , sortable (Just "cstate") (i18nCell MsgTableCorState) $ correctorStateCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "cload") (i18nCell MsgTableCorProportion) $ correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "assigned") (i18nCell MsgTableCorProportion) $ int64Cell <$> view (_dbrOutput . _4 . _1 . _Value) , sortable (toNothing "corrected") (i18nCell MsgTableCorProportion) $ int64Cell <$> view (_dbrOutput . _4 . _2 . _Value) ] validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"] dbtSorting = Map.fromList [ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName ) , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorState ) ] dbtFilter = Map.fromList [ ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) ] dbtFilterUI = mempty dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} -- | Table listing all qualifications that the given user is enrolled in mkQualificationsTable :: UserId -> DB Widget mkQualificationsTable = let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a) -> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a) withType = id validator = def -- TODO & defaultSorting [SortDescBy "valid-until"] in \uid -> dbTableWidget' validator DBTable { dbtIdent = "userQualifications" :: Text , dbtSQLQuery = \(quali `E.InnerJoin` quser) -> do E.on $ quali E.^. QualificationId E.==. quser E.^. QualificationUserQualification E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid return (quali, quser) , dbtRowKey = \(_quali `E.InnerJoin` quser) -> quser E.^. QualificationUserId , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip ) $ qualificationBlockedCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue ) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld ) ] , dbtSorting = mconcat [ sortSchool $ to (\(quali `E.InnerJoin` _) -> quali E.^. QualificationSchool) , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _) -> quali E.^. QualificationName , singletonMap "blocked-due" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserBlockedDue , singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserValidUntil , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserLastRefresh , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserFirstHeld ] , dbtFilter = mempty , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] } 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 $ (,) <$> apopt checkBoxField (fslI MsgActiveAuthTagsSaveCookie & setTooltip MsgActiveAuthTagsSaveCookieTip) (Just False) <*> fmap 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 $ \(saveCookie, authTagActive) -> do when saveCookie $ if | authTagActive == def -> deleteRegisteredCookie CookieActiveAuthTags | otherwise -> setRegisteredCookieJson CookieActiveAuthTags $ authTagActive ^. _ReducedActiveAuthTags 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") getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html getUserNotificationR = postUserNotificationR postUserNotificationR cID = do uid <- decrypt cID (User{userNotificationSettings, userDisplayName}, allocs) <- runDB $ (,) <$> get404 uid <*> getAllocationNotifications uid ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,) <$> notificationForm (Just userNotificationSettings) <*> allocationNotificationForm (Just allocs) mBearer <- askBearer isModal <- hasCustomHeader HeaderIsModal let formWidget = wrapForm nsInnerWdgt def { formAction = Just . SomeRoute $ UserNotificationR cID , formEncoding = nsEnc , formAttrs = [ asyncSubmitAttr | isModal ] } formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do lift . runDB $ do update uid [ UserNotificationSettings =. ns ] setAllocationNotifications uid ans tell . pure =<< messageI Success MsgNotificationSettingsUpdate siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do setTitleI $ MsgNotificationSettingsHeading userDisplayName formWidget data ButtonSetDisplayEmail = BtnSetDisplayEmail deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonSetDisplayEmail instance Finite ButtonSetDisplayEmail nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id instance Button UniWorX ButtonSetDisplayEmail where btnClasses _ = [BCIsButton] getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html getSetDisplayEmailR = postSetDisplayEmailR postSetDisplayEmailR = do uid <- requireAuthId mDisplayEmail <- requireCurrentBearerRestrictions case mDisplayEmail of Nothing -> invalidArgs ["Bearer token required"] Just displayEmail -> do ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm let btnView' = wrapForm btnView def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute SetDisplayEmailR , formEncoding = btnEnc } formResult btnRes $ \case BtnSetDisplayEmail -> do runDB $ update uid [UserDisplayEmail =. displayEmail] addMessageI Success MsgUserDisplayEmailChanged redirect ProfileR siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do setTitleI MsgTitleChangeUserDisplayEmail $(i18nWidgetFile "set-display-email") getCsvOptionsR, postCsvOptionsR :: Handler Html getCsvOptionsR = postCsvOptionsR postCsvOptionsR = do Entity uid User{userCsvOptions} <- requireAuth userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ] return $ examOfficeLabel E.^. ExamOfficeLabelName ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $ csvOptionsForm (Just userCsvOptions) (Set.fromList $ E.unValue <$> examOfficeLabels) formResultModal optionsRes CsvOptionsR $ \opts -> do lift . runDB $ update uid [ UserCsvOptions =. opts ] tell . pure =<< messageI Success MsgCsvOptionsUpdated siteLayoutMsg MsgCsvOptions $ do setTitleI MsgCsvOptions isModal <- hasCustomHeader HeaderIsModal wrapForm optionsWgt' def { formAction = Just $ SomeRoute CsvOptionsR , formEncoding = optionsEnctype , formAttrs = [ asyncSubmitAttr | isModal ] } postLangR :: Handler Void postLangR = do requestedLang <- selectLanguage' appLanguages . hoistMaybe <$> lookupGlobalPostParam PostLanguage lang' <- runDB . updateUserLanguage $ Just requestedLang app <- getYesod let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang'' | otherwise = renderMessage app [] addMessage Success . toHtml $ mr MsgLanguageChanged redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer