606 lines
31 KiB
Haskell
606 lines
31 KiB
Haskell
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
|
|
<input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
|
|
^{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
|