955 lines
46 KiB
Haskell
955 lines
46 KiB
Haskell
module Handler.Profile
|
|
( getProfileR, postProfileR
|
|
, getProfileDataR, makeProfileData
|
|
, getAuthPredsR, postAuthPredsR
|
|
, getUserNotificationR, postUserNotificationR
|
|
, getSetDisplayEmailR, postSetDisplayEmailR
|
|
, getCsvOptionsR, postCsvOptionsR
|
|
, postLangR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Profile
|
|
|
|
-- 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 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 SettingsForm = SettingsForm
|
|
{ stgDisplayName :: UserDisplayName
|
|
, stgDisplayEmail :: UserEmail
|
|
, stgMaxFavourites :: Int
|
|
, stgMaxFavouriteTerms :: Int
|
|
, stgTheme :: Theme
|
|
, stgDateTime :: DateTimeFormat
|
|
, stgDate :: DateTimeFormat
|
|
, stgTime :: DateTimeFormat
|
|
, stgDownloadFiles :: Bool
|
|
, stgWarningDays :: NominalDiffTime
|
|
, stgShowSex :: Bool
|
|
, 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
|
|
<*> 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 <- 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
|
|
-- _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
|
|
|
|
|
|
validateSettings :: User -> FormValidator SettingsForm Handler ()
|
|
validateSettings User{..} = do
|
|
userDisplayName' <- use _stgDisplayName
|
|
|
|
guardValidation MsgUserDisplayNameInvalid $
|
|
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
|
|
|
|
|
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@User{..}) <- requireAuthPair
|
|
userSchools <- fmap (setOf $ folded . _Value) . runDB . 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
|
|
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
|
|
, 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
|
|
] ++ [ 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
|
|
]
|
|
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 MsgMenuProfileData
|
|
dataWidget
|
|
|
|
makeProfileData :: Entity User -> DB Widget
|
|
makeProfileData (Entity uid User{..}) = do
|
|
-- MsgRenderer mr <- getMsgRenderer
|
|
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
|
|
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")
|
|
|
|
|
|
|
|
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
|
|
[ 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)
|
|
<*> 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
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
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
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (course, participant E.^. CourseParticipantRegistration)
|
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
|
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
|
|
, dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
|
|
schoolCell <$> view _courseTerm
|
|
<*> 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
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
}
|
|
|
|
|
|
|
|
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.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 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
|
|
[ sortable (Just "term") (i18nCell MsgTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _1)
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
|
|
schoolCell <$> view _1
|
|
<*> 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
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
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)
|
|
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
|
|
|
dbtProj x = return $ x
|
|
& _dbrOutput . _1 %~ $(E.unValueN 3)
|
|
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _1)
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
|
|
schoolCell <$> view _1
|
|
<*> view _2
|
|
, sortable (Just "course") (i18nCell MsgCourse) $
|
|
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
|
|
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.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 x = return $ x
|
|
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
|
& _dbrOutput . _2 %~ E.unValue
|
|
|
|
dbtColonnade = mconcat
|
|
[ 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
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
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 $ (,)
|
|
<$> 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
|
|
<input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
|
|
^{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
|
|
|
|
((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
|
|
csvOptionsForm (Just userCsvOptions)
|
|
|
|
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
|