module Handler.Profile where import Import import Handler.Utils import Handler.Utils.Table.Cells import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) data SettingsForm = SettingsForm { stgMaxFavourties :: Int , stgTheme :: Theme , stgDateTime :: DateTimeFormat , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool , stgNotificationSettings :: NotificationSettings } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template = identifyForm FIDsettings $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm <$ aformSection MsgFormCosmetics <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> 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 <*> areq checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) <* aformSection MsgFormNotifications <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (display t) t (toPathPiece t) | t <- universeF] -- -- Version with proper grouping: -- -- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm -- makeSettingForm template = identForm FIDsettings $ \html -> do -- (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2 -- <$> aFormGroup "Cosmetics" cosmeticsForm -- <*> aFormGroup "Notifications" notificationsForm -- <* submitButton -- return (result, widget) -- no validation required here -- where -- settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm -- settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm -- themeList = [Option (display t) t (toPathPiece t) | t <- universeF] -- cosmeticsForm = (,,,,) -- <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here -- (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> 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) -- notificationsForm = (,) -- <$> areq checkBoxField (fslI MsgDownloadFiles -- & setTooltip MsgDownloadFilesTip -- ) (stgDownloadFiles <$> template) -- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) -- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template) notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True where nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template) 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 getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = do (uid, User{..}) <- requireAuthPair let settingsTemplate = Just SettingsForm { stgMaxFavourties = userMaxFavourites , stgTheme = userTheme , stgDateTime = userDateTimeFormat , stgDate = userDateFormat , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles , stgNotificationSettings = userNotificationSettings } ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate formResult res $ \SettingsForm{..} -> do runDB $ do update uid [ UserMaxFavourites =. stgMaxFavourties , UserTheme =. stgTheme , UserDateTimeFormat =. stgDateTime , UserDateFormat =. stgDate , UserTimeFormat =. stgTime , UserDownloadFiles =. stgDownloadFiles , UserNotificationSettings =. stgNotificationSettings ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] [ Desc CourseFavouriteTime , OffsetBy stgMaxFavourties ] mapM_ delete oldFavs addMessageI Info 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 setTitle . toHtml $ "Profil " <> userIdent 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") $(widgetFile "profile/profile") getProfileDataR :: Handler Html getProfileDataR = do userEnt <- requireAuth dataWidget <- runDB $ makeProfileData userEnt defaultLayout $ do dataWidget $(widgetFile "dsgvDisclaimer") makeProfileData :: Entity User -> DB Widget makeProfileData (Entity uid User{..}) = do -- MsgRenderer mr <- getMsgRenderer admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do E.where_ $ adright E.^. UserAdminUser E.==. E.val uid E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId return (school E.^. SchoolShorthand) lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId return (school E.^. SchoolShorthand) 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 let examTable = [whamlet|Klausuren werden momentan leider noch nicht unterstützt.|] let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication return $(widgetFile "profileData") mkOwnedCoursesTable :: UserId -> DB (Bool, Widget) -- Table listing all courses that the given user is a lecturer for 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 = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))) dbtColonnade = mconcat [ dbRow , sortable (Just "term") (i18nCell MsgTerm & 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 MsgCourseSchool) $ schoolCell <$> view (_dbrOutput . _1 . re _Just) <*> view (_dbrOutput . _2 ) , sortable (Just "course") (i18nCell MsgCourse) $ 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 in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} mkEnrolledCoursesTable :: UserId -> DB Widget -- Table listing all courses that the given user is enrolled in 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 return (course, participant E.^. CourseParticipantRegistration) , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue , dbtColonnade = mconcat [ dbRow , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ schoolCell <$> view ( _courseTerm . re _Just) <*> view _courseSchool , sortable (Just "course") (i18nCell MsgCourse) $ courseCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "time") (i18nCell MsgRegistered) $ 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 } mkSubmissionTable :: UserId -> DB Widget -- Table listing all submissions for the given user 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.sub_select . E.from $ \subEdit -> do E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid return . E.max_ $ subEdit E.^. SubmissionEditTime dbtProj x = return $ x & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _2 %~ E.unValue & _dbrOutput . _4 %~ E.unValue dbtColonnade = mconcat [ dbRow , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view ( _1. re _Just) <*> view _2 , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ sheetCell <$> view _1 <*> view _2 , sortable (toNothingS "submission") (i18nCell MsgSubmission) . 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 in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} -- in do dbtSQLQuery <- dbtSQLQuery' -- dbtSorting <- dbtSorting' -- return $ dbTableWidget' validator $ DBTable {..} mkSubmissionGroupTable :: UserId -> DB Widget -- Table listing all submissions for the given user 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, lastSGEdit sgroup) dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime dbtProj x = return $ x & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _3 %~ E.unValue dbtColonnade = mconcat [ dbRow , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ schoolCell <$> view ( _1. re _Just) <*> view _2 , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ maybe mempty textCell <$> view _submissionGroupName , sortable (Just "edit") (i18nCell MsgLastEdit) $ maybe mempty dateTimeCell <$> view (_dbrOutput . _3) ] 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 = 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 ) , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup) ] 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 in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} mkCorrectionsTable :: UserId -> DB Widget -- Table listing sum of corrections made by the given user per sheet mkCorrectionsTable = let dbtIdent = "corrections" :: Text dbtStyle = def -- TODO Continue here 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.sub_select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) return E.countRows corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do 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) return E.countRows 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 x = return $ x & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) & _dbrOutput . _2 %~ E.unValue dbtColonnade = mconcat [ dbRow , sortable (Just "term") (i18nCell MsgTerm) $ termCellCL <$> view (_dbrOutput . _1) , sortable (Just "school") (i18nCell MsgCourseSchool) $ schoolCellCL <$> view (_dbrOutput . _1) , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view (_dbrOutput . _1) , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ sheetCell <$> view _1 <*> view _2 , sortable (Just "cstate") (i18nCell MsgCorState) $ correctorStateCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "cload") (i18nCell MsgCorProportion) $ correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "assigned") (i18nCell MsgCorProportion) $ int64Cell <$> view (_dbrOutput . _4 . _1 . _Value) , sortable (toNothing "corrected") (i18nCell MsgCorProportion) $ 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 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") getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html getUserNotificationR = postUserNotificationR postUserNotificationR cID = do uid <- decrypt cID User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings mJwt <- askJwt isModal <- hasCustomHeader HeaderIsModal let formWidget = wrapForm nsInnerWdgt def { formAction = Just . SomeRoute $ UserNotificationR cID , formEncoding = nsEnc , formAttrs = [ ("data-ajax-submit", "") | isModal ] } formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do lift . runDB $ update uid [ UserNotificationSettings =. ns ] tell . pure =<< messageI Success MsgNotificationSettingsUpdate siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do setTitleI $ MsgNotificationSettingsHeading userDisplayName formWidget