602 lines
31 KiB
Haskell
602 lines
31 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE MultiWayIf, LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
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 Data.Map ((!))
|
|
import qualified Data.Set as Set
|
|
-- 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 = identForm FIDsettings $ \html -> do
|
|
let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
|
|
<$> 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)
|
|
<*> areq checkBoxField (fslI MsgDownloadFiles
|
|
& setTooltip MsgDownloadFilesTip
|
|
) (stgDownloadFiles <$> template)
|
|
<*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
|
|
<* submitButton
|
|
return (result, widget) -- no validation required here
|
|
where
|
|
nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
|
|
areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
|
|
nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
|
|
nsFieldView (res, fvInput) = do
|
|
mr <- getMessageRender
|
|
let fvLabel = toHtml $ mr MsgNotificationSettings
|
|
fvTooltip = mempty
|
|
fvRequired = True
|
|
fvErrors
|
|
| FormFailure (err:_) <- res = Just $ toHtml err
|
|
| otherwise = Nothing
|
|
fvId <- newIdent
|
|
return (res, pure FieldView{..})
|
|
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
|
|
|
|
|
|
|
|
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 $ makeSettingForm settingsTemplate
|
|
case res of
|
|
(FormSuccess 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 -- TODO: them change does not happen without redirect
|
|
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
|
|
_ -> return ()
|
|
|
|
|
|
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
|
|
(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)
|
|
)
|
|
<*>
|
|
(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)
|
|
)
|
|
<*>
|
|
(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)
|
|
)
|
|
<*>
|
|
(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 ( ( studydegree E.^. StudyDegreeName
|
|
, studydegree E.^. StudyDegreeKey
|
|
)
|
|
, ( studyterms E.^. StudyTermsName
|
|
, studyterms E.^. StudyTermsKey
|
|
)
|
|
, studyfeat E.^. StudyFeaturesType
|
|
, studyfeat E.^. StudyFeaturesSemester)
|
|
)
|
|
let formText = Just MsgSettings
|
|
actionUrl = ProfileR
|
|
settingsForm = $(widgetFile "formPageI18n")
|
|
defaultLayout $ do
|
|
setTitle . toHtml $ userIdent <> "'s User page"
|
|
$(widgetFile "profile")
|
|
$(widgetFile "dsgvDisclaimer")
|
|
|
|
postProfileDataR :: Handler Html
|
|
postProfileDataR = do
|
|
((btnResult,_), _) <- runFormPost $ buttonForm
|
|
case btnResult of
|
|
(FormSuccess BtnDelete) -> do
|
|
(uid, User{..}) <- requireAuthPair
|
|
clearCreds False -- Logout-User
|
|
((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
|
|
-- addMessageIHamlet
|
|
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
|
|
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
|
|
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
|
|
defaultLayout $ do
|
|
$(widgetFile "deletedUser")
|
|
|
|
(FormSuccess BtnAbort ) -> do
|
|
addMessageI Info MsgAborted
|
|
redirect ProfileDataR
|
|
_other -> getProfileDataR
|
|
|
|
|
|
|
|
deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
|
|
deleteUser duid = do
|
|
-- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
|
|
-- We delete all files tied to submissions where the user is the lone submissionUser
|
|
|
|
-- Do not deleteCascade submissions where duid is the corrector:
|
|
updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
|
|
|
|
groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64))
|
|
singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
|
|
deleteCascade duid
|
|
forM_ singleSubmissions $ \(E.Value submissionId) -> do
|
|
deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId
|
|
deleteCascade submissionId
|
|
deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
|
|
|
|
deletedSubmissionGroups <- deleteSingleSubmissionGroups
|
|
return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
|
|
where
|
|
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
|
|
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
|
|
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
|
|
let numBuddies = E.sub_select $ E.from $ \subUsers -> do
|
|
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
|
|
return E.countRows
|
|
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
|
|
E.&&. (whereBuddies numBuddies)
|
|
return $ submission E.^. SubmissionId
|
|
|
|
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
|
|
getSubmissionFiles subId = E.select $ E.from $ \file -> do
|
|
E.where_ $ E.exists $ E.from $ \submissionFile -> do
|
|
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
|
|
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
|
|
return $ file E.^. FileId
|
|
|
|
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
|
|
E.where_ $ E.exists $ E.from $ \subGroupUser -> do
|
|
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
|
|
E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
|
|
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
|
|
|
|
|
|
|
|
|
|
|
|
|
|
getProfileDataR :: Handler Html
|
|
getProfileDataR = do
|
|
(uid, User{..}) <- requireAuthPair
|
|
-- mr <- getMessageRender
|
|
-- Tabelle mit eigenen Kursen
|
|
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
|
|
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
|
enrolledCoursesTable <- mkEnrolledCoursesTable uid
|
|
-- Tabelle mit allen Klausuren und Noten
|
|
examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
|
|
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
|
submissionTable <- mkSubmissionTable uid
|
|
-- Tabelle mit allen Abgabegruppen
|
|
submissionGroupTable <- mkSubmissionGroupTable uid
|
|
-- Tabelle mit allen Korrektor-Aufgaben
|
|
correctionsTable <- mkCorrectionsTable uid
|
|
-- Tabelle mit allen eigenen Tutorials
|
|
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
|
|
-- Tabelle mit allen Tutorials
|
|
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
|
|
-- Delete Button
|
|
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
|
|
-- TODO: move this into a Message and/or Widget-File
|
|
let delWdgt = [whamlet|
|
|
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
|
|
<h2>
|
|
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
|
|
<div .container>
|
|
Während der Testphase von Uni2work können Sie hiermit
|
|
Ihren Account bei Uni2work vollständig löschen.
|
|
Mit Ihrem Campus-Account können Sie sich aber danach
|
|
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
|
|
<div .container>
|
|
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
|
|
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
|
|
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
|
|
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
|
|
<div .container>
|
|
<em>Achtung:
|
|
Auch abgegebene Hausübungen werden gelöscht!
|
|
Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
|
|
kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
|
|
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
|
|
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
|
|
auch nicht mehr rekonstruiert/berücksichtigt werden.)
|
|
<div .container>
|
|
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
|
|
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
|
|
aufbewahrt werden müssen.
|
|
<div .container>
|
|
^{btnWdgt}
|
|
|]
|
|
defaultLayout $ do
|
|
$(widgetFile "profileData")
|
|
$(widgetFile "dsgvDisclaimer")
|
|
|
|
|
|
|
|
mkOwnedCoursesTable :: UserId -> Handler (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
|
|
)
|
|
dbtProj = \x -> return $ x & _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 [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
|
|
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 )
|
|
]
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..})
|
|
|
|
|
|
|
|
mkEnrolledCoursesTable :: UserId -> Handler 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 [("time",SortDesc)]
|
|
|
|
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)
|
|
, 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 $ timeCell 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 )
|
|
]
|
|
, dbtStyle = def
|
|
}
|
|
|
|
|
|
|
|
mkSubmissionTable :: UserId -> Handler 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)
|
|
|
|
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 timeCell regTime
|
|
, sortable (Just "edit") (i18nCell MsgLastEditByUser) $
|
|
maybe mempty timeCell <$> 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 [("edit",SortDesc)]
|
|
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 )
|
|
]
|
|
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 -> Handler 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)
|
|
|
|
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 timeCell <$> 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 [("edit",SortDesc)]
|
|
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 )
|
|
]
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
|
in dbTableWidget' validator $ DBTable {..}
|
|
|
|
|
|
|
|
mkCorrectionsTable :: UserId -> Handler 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))
|
|
|
|
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 . _unValue)
|
|
, sortable (toNothing "corrected") (i18nCell MsgCorProportion) $
|
|
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
|
|
]
|
|
|
|
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
|
|
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)
|
|
]
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
|
in dbTableWidget' validator $ DBTable {..}
|
|
|