1146 lines
57 KiB
Haskell
1146 lines
57 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Profile
|
|
( getProfileR, postProfileR
|
|
, getForProfileR, postForProfileR
|
|
, getProfileDataR, makeProfileData
|
|
, getForProfileDataR
|
|
, getAuthPredsR, postAuthPredsR
|
|
, getUserNotificationR, postUserNotificationR
|
|
, getSetDisplayEmailR, postSetDisplayEmailR
|
|
, getCsvOptionsR, postCsvOptionsR
|
|
, postLangR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Profile
|
|
|
|
import Utils.Print (validCmdArgument)
|
|
|
|
-- import Colonnade hiding (fromMaybe, singleton)
|
|
-- import Yesod.Colonnade
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
-- import Database.Esqueleto ((^.))
|
|
import qualified Data.Text as Text
|
|
import Data.List (inits)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Jobs
|
|
|
|
import Foundation.Yesod.Auth (updateUserLanguage)
|
|
|
|
|
|
data ExamOfficeSettings
|
|
= ExamOfficeSettings
|
|
{ eosettingsGetSynced :: Bool
|
|
, eosettingsGetLabels :: Bool
|
|
, eosettingsLabels :: EOLabels
|
|
}
|
|
|
|
type EOLabelData
|
|
= ( ExamOfficeLabelName
|
|
, MessageStatus -- status
|
|
, Int -- priority; also used for label ordering
|
|
)
|
|
type EOLabels = Map (Either ExamOfficeLabelName ExamOfficeLabelId) EOLabelData
|
|
|
|
data SettingsForm = SettingsForm
|
|
{ stgDisplayName :: UserDisplayName
|
|
, stgDisplayEmail :: UserEmail
|
|
, stgMaxFavourites :: Int
|
|
, stgMaxFavouriteTerms :: Int
|
|
, stgTheme :: Theme
|
|
, stgDateTime :: DateTimeFormat
|
|
, stgDate :: DateTimeFormat
|
|
, stgTime :: DateTimeFormat
|
|
, stgDownloadFiles :: Bool
|
|
, stgWarningDays :: NominalDiffTime
|
|
, stgShowSex :: Bool
|
|
|
|
, stgPinPassword :: Maybe Text
|
|
, stgPrefersPostal :: Bool
|
|
, stgPostAddress :: Maybe StoredMarkup
|
|
|
|
, stgExamOfficeSettings :: ExamOfficeSettings
|
|
, stgSchools :: Set SchoolId
|
|
, stgNotificationSettings :: NotificationSettings
|
|
}
|
|
makeLenses_ ''SettingsForm
|
|
|
|
data NotificationTriggerKind
|
|
= NTKAll
|
|
| NTKCourseParticipant
|
|
| NTKSubmissionUser
|
|
| NTKExamParticipant
|
|
| NTKCorrector
|
|
| NTKCourseLecturer
|
|
| NTKFunctionary SchoolFunction
|
|
deriving (Eq, Ord, Generic)
|
|
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
|
|
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
|
|
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
|
|
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
|
|
NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation
|
|
where
|
|
mr = renderMessage f ls
|
|
|
|
|
|
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
|
|
<*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template)
|
|
<*> apopt checkBoxField (fslI MsgPrefersPostal & setTooltip MsgPostalTip) (stgPrefersPostal <$> template)
|
|
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template)
|
|
|
|
<*> examOfficeForm (stgExamOfficeSettings <$> template)
|
|
<*> schoolsForm (stgSchools <$> template)
|
|
<*> notificationForm (stgNotificationSettings <$> template)
|
|
return (result, widget) -- no validation here, done later by validateSettings
|
|
where
|
|
themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]
|
|
|
|
schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
|
|
schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
|
|
where
|
|
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
|
|
schoolsForm' = do
|
|
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
|
|
|
|
let
|
|
schoolForm (Entity ssh School{schoolName})
|
|
= fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template)
|
|
|
|
fold <$> mapM schoolForm allSchools
|
|
|
|
schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX])
|
|
schoolsFormView (res, fvInput) = do
|
|
mr <- getMessageRender
|
|
let fvLabel = toHtml $ mr MsgUserSchools
|
|
fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip
|
|
fvRequired = False
|
|
fvErrors
|
|
| FormFailure (err : _) <- res = Just $ toHtml err
|
|
| otherwise = Nothing
|
|
fvId <- newIdent
|
|
return (res, pure FieldView{..})
|
|
|
|
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
|
|
notificationForm template = wFormToAForm $ do
|
|
mbUid <- liftHandler maybeAuthId
|
|
isAdmin <- lift . lift $ hasReadAccessTo AdminR
|
|
|
|
let
|
|
sectionIsHidden :: NotificationTriggerKind -> DB Bool
|
|
sectionIsHidden = \case
|
|
_
|
|
| isAdmin
|
|
-> return False
|
|
NTKAll
|
|
-> return False
|
|
NTKCourseParticipant
|
|
| Just uid <- mbUid
|
|
-> fmap not . E.selectExists . E.from $ \courseParticipant ->
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
NTKSubmissionUser
|
|
| Just uid <- mbUid
|
|
-> fmap not . E.selectExists . E.from $ \submissionUser ->
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
NTKExamParticipant
|
|
| Just uid <- mbUid
|
|
-> fmap not . E.selectExists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
NTKCorrector
|
|
| Just uid <- mbUid
|
|
-> fmap not . E.selectExists . E.from $ \sheetCorrector ->
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
NTKCourseLecturer
|
|
| Just uid <- mbUid
|
|
-> fmap not . E.selectExists . E.from $ \lecturer ->
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
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
|
|
_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
|
|
NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice
|
|
NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice
|
|
NTCourseRegistered -> Just NTKAll
|
|
NTQualificationExpiry -> Just NTKAll
|
|
NTQualificationReminder -> Just NTKAll
|
|
-- _other -> Nothing
|
|
|
|
forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate, NTQualificationExpiry]
|
|
|
|
aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
|
|
|
|
|
|
examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings
|
|
examOfficeForm template = wFormToAForm $ do
|
|
(_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair
|
|
currentRoute <- fromMaybe (error "examOfficeForm called from 404-handler") <$> liftHandler getCurrentRoute
|
|
mr <- getMessageRender
|
|
|
|
let
|
|
userExamOfficeLabels :: EOLabels
|
|
userExamOfficeLabels = maybe mempty eosettingsLabels template
|
|
|
|
eoLabelsForm :: AForm Handler EOLabels
|
|
eoLabelsForm = wFormToAForm $ do
|
|
let
|
|
miAdd :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> (Text -> Text)
|
|
-> FieldView UniWorX
|
|
-> Maybe
|
|
(Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)
|
|
-> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)))
|
|
)
|
|
miAdd _ _ _ nudge submitView = Just $ \csrf -> do
|
|
(addRes, addView) <- mpreq textField (fslI MsgExamOfficeLabelName & addName (nudge "name")) Nothing
|
|
let
|
|
addRes' = addRes <&> \nLabel oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
|
|
| Set.member (Left nLabel) . Set.fromList $ Map.elems oldData
|
|
-> FormFailure [mr MsgExamOfficeLabelAlreadyExists]
|
|
| otherwise
|
|
-> FormSuccess $ Map.singleton kStart (Left nLabel)
|
|
return (addRes', $(widgetFile "profile/exam-office-labels/add"))
|
|
|
|
miCell :: ListPosition
|
|
-> Either ExamOfficeLabelName ExamOfficeLabelId
|
|
-> Maybe EOLabelData
|
|
-> (Text -> Text)
|
|
-> Form EOLabelData
|
|
miCell _ eoLabel initRes nudge csrf = do
|
|
labelIdent <- case eoLabel of
|
|
Left lblName -> return lblName
|
|
Right lblId -> do
|
|
ExamOfficeLabel{examOfficeLabelName} <- liftHandler . runDB $ getJust lblId
|
|
return examOfficeLabelName
|
|
(statusRes, statusView) <- mreq (selectField optionsFinite) (fslI MsgExamOfficeLabelStatus & addName (nudge "status")) ((\(_,x,_) -> x) <$> initRes)
|
|
(priorityRes, priorityView) <- mreq intField (fslI MsgExamOfficeLabelPriority & addName (nudge "priority")) (((\(_,_,x) -> x) <$> initRes) <|> Just 0)
|
|
let
|
|
res :: FormResult EOLabelData
|
|
res = (,,) <$> FormSuccess labelIdent <*> statusRes <*> priorityRes
|
|
return (res, $(widgetFile "profile/exam-office-labels/cell"))
|
|
|
|
miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)
|
|
-> ListPosition
|
|
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
|
miDelete = miDeleteList
|
|
|
|
miAddEmpty :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Set ListPosition
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miButtonAction :: forall p.
|
|
PathPiece p
|
|
=> p
|
|
-> Maybe (SomeRoute UniWorX)
|
|
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
miLayout :: ListLength
|
|
-> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData)
|
|
-> Map ListPosition Widget
|
|
-> Map ListPosition (FieldView UniWorX)
|
|
-> Map (Natural, ListPosition) Widget
|
|
-> Widget
|
|
miLayout lLength _ cellWdgts delButtons addWdgets = $(widgetFile "profile/exam-office-labels/layout")
|
|
|
|
miIdent :: Text
|
|
miIdent = "exam-office-labels"
|
|
|
|
filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData))
|
|
filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels
|
|
|
|
fmap (Map.fromList . Map.elems) <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData
|
|
|
|
userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR
|
|
if userIsExamOffice
|
|
then
|
|
aFormToWForm $ ExamOfficeSettings
|
|
<$ aformSection MsgFormExamOffice
|
|
<*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template)
|
|
<*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template)
|
|
<*> eoLabelsForm
|
|
else
|
|
return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template
|
|
|
|
|
|
validateSettings :: User -> FormValidator SettingsForm Handler ()
|
|
validateSettings User{..} = do
|
|
userDisplayName' <- use _stgDisplayName
|
|
guardValidation MsgUserDisplayNameInvalid $
|
|
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
|
|
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
|
|
|
userDisplayEmail' <- use _stgDisplayEmail
|
|
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
|
|
validEmail' userDisplayEmail'
|
|
|
|
userPostAddress' <- use _stgPostAddress
|
|
let postalNotSet = isNothing userPostAddress'
|
|
postalIsValid = validPostAddress userPostAddress'
|
|
guardValidation MsgUserPostalInvalid $
|
|
postalNotSet || postalIsValid
|
|
|
|
userPrefersPostal' <- use _stgPrefersPostal
|
|
guardValidation MsgUserPrefersPostalInvalid $
|
|
not $ userPrefersPostal' && postalNotSet
|
|
|
|
userPinPassword' <- use _stgPinPassword
|
|
let pinBad = validCmdArgument =<< userPinPassword'
|
|
pinMinChar = 5
|
|
pinLength = maybe 0 length userPinPassword'
|
|
whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
|
|
guardValidation (MsgPDFPasswordTooShort pinMinChar) $ userPrefersPostal' || pinMinChar <= pinLength
|
|
|
|
|
|
data ButtonResetTokens = BtnResetTokens
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
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)
|
|
instance Universe ProfileAnchor
|
|
instance Finite ProfileAnchor
|
|
|
|
nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
|
|
|
|
|
|
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
|
|
getForProfileR = postForProfileR
|
|
postForProfileR cID = do
|
|
uid <- decrypt cID
|
|
user <- runDB $ get404 uid
|
|
serveProfileR (uid, user)
|
|
|
|
getProfileR, postProfileR :: Handler Html
|
|
getProfileR = postProfileR
|
|
postProfileR = requireAuthPair >>= serveProfileR
|
|
|
|
serveProfileR :: (UserId, User) -> Handler Html
|
|
serveProfileR (uid, user@User{..}) = do
|
|
(userSchools, userExamOfficeLabels) <- runDB $ do
|
|
userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
|
E.where_ . E.exists . E.from $ \userSchool ->
|
|
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
|
|
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
|
|
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
|
|
return $ school E.^. SchoolId
|
|
userExamOfficeLabels <- selectList [ ExamOfficeLabelUser ==. uid ] []
|
|
return (userSchools, userExamOfficeLabels)
|
|
let settingsTemplate = Just SettingsForm
|
|
{ stgDisplayName = userDisplayName
|
|
, stgDisplayEmail = userDisplayEmail
|
|
, stgMaxFavourites = userMaxFavourites
|
|
, stgMaxFavouriteTerms = userMaxFavouriteTerms
|
|
, stgTheme = userTheme
|
|
, stgDateTime = userDateTimeFormat
|
|
, stgDate = userDateFormat
|
|
, stgTime = userTimeFormat
|
|
, stgDownloadFiles = userDownloadFiles
|
|
, stgSchools = userSchools
|
|
, stgNotificationSettings = userNotificationSettings
|
|
, stgWarningDays = userWarningDays
|
|
, stgShowSex = userShowSex
|
|
, stgPinPassword = userPinPassword
|
|
, stgPostAddress = userPostAddress
|
|
, stgPrefersPostal = userPrefersPostal
|
|
, stgExamOfficeSettings = ExamOfficeSettings
|
|
{ eosettingsGetSynced = userExamOfficeGetSynced
|
|
, eosettingsGetLabels = userExamOfficeGetLabels
|
|
, eosettingsLabels = flip foldMap userExamOfficeLabels $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)
|
|
}
|
|
}
|
|
((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
|
|
|
formResult res $ \SettingsForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
runDBJobs $ do
|
|
update uid $
|
|
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
|
|
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
|
|
[ UserDisplayName =. stgDisplayName
|
|
, UserMaxFavourites =. stgMaxFavourites
|
|
, UserMaxFavouriteTerms =. stgMaxFavouriteTerms
|
|
, UserTheme =. stgTheme
|
|
, UserDateTimeFormat =. stgDateTime
|
|
, UserDateFormat =. stgDate
|
|
, UserTimeFormat =. stgTime
|
|
, UserDownloadFiles =. stgDownloadFiles
|
|
, UserWarningDays =. stgWarningDays
|
|
, UserNotificationSettings =. stgNotificationSettings
|
|
, UserShowSex =. stgShowSex
|
|
, UserPinPassword =. stgPinPassword
|
|
, UserPostAddress =. stgPostAddress
|
|
, UserPrefersPostal =. stgPrefersPostal
|
|
, UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced)
|
|
, UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels)
|
|
]
|
|
updateFavourites Nothing
|
|
when (stgDisplayEmail /= userDisplayEmail) $ do
|
|
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
|
|
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
|
|
let
|
|
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
|
|
forM_ symDiff $ \ssh -> if
|
|
| ssh `Set.member` stgSchools
|
|
-> void $ upsert UserSchool
|
|
{ userSchoolSchool = ssh
|
|
, userSchoolUser = uid
|
|
, userSchoolIsOptOut = False
|
|
}
|
|
[ UserSchoolIsOptOut =. False
|
|
]
|
|
| otherwise
|
|
-> void $ upsert UserSchool
|
|
{ userSchoolSchool = ssh
|
|
, userSchoolUser = uid
|
|
, userSchoolIsOptOut = True
|
|
}
|
|
[ UserSchoolIsOptOut =. True
|
|
]
|
|
let
|
|
oldExamLabels = userExamOfficeLabels
|
|
newExamLabels = stgExamOfficeSettings & eosettingsLabels
|
|
forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
|
|
E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
|
|
E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
|
|
when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
|
|
update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
|
|
delete eolid
|
|
forM_ (Map.toList newExamLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of
|
|
Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. }
|
|
[ ExamOfficeLabelName =. examOfficeLabelName
|
|
, ExamOfficeLabelStatus =. examOfficeLabelStatus
|
|
, ExamOfficeLabelPriority =. examOfficeLabelPriority
|
|
]
|
|
Right lblId -> update lblId
|
|
[ ExamOfficeLabelName =. examOfficeLabelName
|
|
, ExamOfficeLabelStatus =. examOfficeLabelStatus
|
|
, ExamOfficeLabelPriority =. examOfficeLabelPriority
|
|
]
|
|
addMessageI Success MsgSettingsUpdate
|
|
redirect $ ProfileR :#: ProfileSettings
|
|
|
|
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
|
|
|
|
formResult tokenRes $ \BtnResetTokens -> do
|
|
now <- liftIO getCurrentTime
|
|
runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
|
|
addMessageI Info MsgTokensResetSuccess
|
|
redirect $ ProfileR :#: ProfileResetTokens
|
|
|
|
tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
|
|
|
|
siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
|
|
setTitleI MsgProfileTitle
|
|
let settingsForm =
|
|
wrapForm formWidget FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
|
|
, formEncoding = formEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just ProfileSettings
|
|
}
|
|
tokenForm =
|
|
wrapForm tokenFormWidget FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
|
|
, formEncoding = tokenEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just ProfileResetTokens
|
|
}
|
|
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
|
|
displayNameRules = $(i18nWidgetFile "profile/displayNameRules")
|
|
$(widgetFile "profile/profile")
|
|
|
|
|
|
getProfileDataR :: Handler Html
|
|
getProfileDataR = do
|
|
userEnt <- requireAuth
|
|
dataWidget <- runDB $ makeProfileData userEnt
|
|
defaultLayout $ do
|
|
setTitleI MsgHeadingProfileData
|
|
dataWidget
|
|
|
|
getForProfileDataR :: CryptoUUIDUser -> Handler Html
|
|
getForProfileDataR cID = do
|
|
uid <- decrypt cID
|
|
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
|
|
defaultLayout $ do
|
|
setTitleI $ MsgHeadingForProfileData $ userDisplayName user
|
|
dataWidget
|
|
|
|
makeProfileData :: Entity User -> DB Widget
|
|
makeProfileData (Entity uid User{..}) = do
|
|
now <- liftIO getCurrentTime
|
|
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
|
|
-- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
|
|
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.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
|
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
|
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (studyfeat, studydegree, studyterms)
|
|
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
|
E.orderBy [E.asc (comp E.^. CompanyName)] -- E.desc (usrComp E.^. UserCompanySupervisor),
|
|
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
|
let companies = intersperse (text2markup ", ") $
|
|
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
|
icnSuper = text2markup " " <> icon IconSupervisor
|
|
supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
|
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
|
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
|
|
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
|
|
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
|
let numSupervisors = length supervisors'
|
|
supervisors = intersperse (text2widget ", ") $
|
|
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
|
icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
|
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
|
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
|
|
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
|
let numSupervisees = length supervisees'
|
|
supervisees = intersperse (text2widget ", ") $
|
|
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
|
|
-- icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
|
--Tables
|
|
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
|
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
|
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
|
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
|
|
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
|
|
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
|
|
let examTable, ownTutorialTable, tutorialTable :: Widget
|
|
examTable = i18n MsgPersonalInfoExamAchievementsWip
|
|
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
|
|
tutorialTable = i18n MsgPersonalInfoTutorialsWip
|
|
|
|
cID <- encrypt uid
|
|
mCRoute <- getCurrentRoute
|
|
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
|
|
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
|
|
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
|
|
|
|
let profileRemarks = $(i18nWidgetFile "profile-remarks")
|
|
return $(widgetFile "profileData")
|
|
|
|
|
|
|
|
-- | Table listing all courses that the given user is a lecturer for
|
|
mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
|
|
mkOwnedCoursesTable =
|
|
let dbtIdent = "courseOwnership" :: Text
|
|
dbtStyle = def
|
|
|
|
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
|
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
|
|
withType = id
|
|
|
|
dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
return ( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
)
|
|
dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
|
|
dbtProj = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
|
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm & cellAttrs .~ [("priority","0")]) $ do
|
|
tid <- view (_dbrOutput . _1)
|
|
return $ indicatorCell -- return True if one cell is produced here
|
|
`mappend` termCell tid
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
|
|
schoolCell <$> view (_dbrOutput . _1)
|
|
<*> view (_dbrOutput . _2 )
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $
|
|
courseCellCL <$> view _dbrOutput
|
|
]
|
|
|
|
validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
|
|
dbtSorting = Map.fromList
|
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool )
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
|
]
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
|
|
|
|
|
-- | Table listing all courses that the given user is enrolled in
|
|
mkEnrolledCoursesTable :: UserId -> DB Widget
|
|
mkEnrolledCoursesTable =
|
|
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
|
withType = id
|
|
|
|
validator = def & defaultSorting [SortDescBy "time"]
|
|
|
|
in \uid -> dbTableWidget' validator
|
|
DBTable
|
|
{ dbtIdent = "courseMembership" :: Text
|
|
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
|
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (course, participant E.^. CourseParticipantRegistration)
|
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
|
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
|
|
, dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
|
|
schoolCell <$> view _courseTerm
|
|
<*> view _courseSchool
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $
|
|
courseCell <$> view (_dbrOutput . _1 . _entityVal)
|
|
, sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
|
|
regTime <- view $ _dbrOutput . _2
|
|
return $ dateTimeCell regTime
|
|
]
|
|
, dbtSorting = Map.fromList
|
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
|
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool)
|
|
, ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
|
|
]
|
|
, dbtFilter = Map.fromList
|
|
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName )
|
|
, ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
|
|
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
|
|
]
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
|
|
|
|
-- | Table listing all submissions for the given user
|
|
mkSubmissionTable :: UserId -> DB Widget
|
|
mkSubmissionTable =
|
|
let dbtIdent = "submissions" :: Text
|
|
dbtStyle = def
|
|
|
|
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
|
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
|
|
withType = id
|
|
|
|
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
|
|
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
|
|
let crse = ( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
)
|
|
let sht = sheet E.^. SheetName
|
|
return (crse, sht, submission, lastSubEdit uid submission)
|
|
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
|
|
|
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
|
E.subSelectMaybe . E.from $ \subEdit -> do
|
|
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
|
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
|
|
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
|
|
|
dbtProj = dbtProjId
|
|
<&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
|
<&> _dbrOutput . _2 %~ E.unValue
|
|
<&> _dbrOutput . _4 %~ E.unValue
|
|
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _1)
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
|
|
schoolCell <$> view _1
|
|
<*> view _2
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $
|
|
courseCellCL <$> view (_dbrOutput . _1)
|
|
, sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $
|
|
sheetCell <$> view _1
|
|
<*> view _2
|
|
, sortable (toNothingS "submission") (i18nCell MsgTableSubmission) . magnify _dbrOutput $
|
|
submissionCell <$> view _1
|
|
<*> view _2
|
|
<*> view (_3 . _entityKey)
|
|
-- , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
|
|
-- regTime <- view $ _dbrOutput . _4
|
|
-- return $ maybe mempty dateTimeCell regTime
|
|
, sortable (Just "edit") (i18nCell MsgLastEditByUser) $
|
|
maybe mempty dateTimeCell <$> view (_dbrOutput . _4)
|
|
]
|
|
|
|
validator = def -- DUPLICATED CODE: Handler.Corrections
|
|
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
|
& restrictSorting (\name _ -> name /= "corrector")
|
|
& defaultSorting [SortDescBy "edit"]
|
|
dbtSorting' uid = Map.fromList
|
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool )
|
|
, ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName )
|
|
, ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission )
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
|
]
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
|
dbtSorting = dbtSorting' uid
|
|
in dbTableWidget' validator DBTable{..}
|
|
-- in do dbtSQLQuery <- dbtSQLQuery'
|
|
-- dbtSorting <- dbtSorting'
|
|
-- return $ dbTableWidget' validator $ DBTable {..}
|
|
|
|
|
|
-- | Table listing all submissions for the given user
|
|
mkSubmissionGroupTable :: UserId -> DB Widget
|
|
mkSubmissionGroupTable =
|
|
let dbtIdent = "subGroups" :: Text
|
|
dbtStyle = def
|
|
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
|
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
|
|
withType = id
|
|
|
|
dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
|
|
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
|
|
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
|
|
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
let crse = ( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
)
|
|
return (crse, sgroup)
|
|
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
|
|
|
dbtProj = dbtProjId
|
|
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
|
|
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
|
termCell <$> view (_dbrOutput . _1 . _1)
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
|
|
schoolCell <$> view _1
|
|
<*> view _2
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $
|
|
courseCellCL <$> view (_dbrOutput . _1)
|
|
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
|
|
cell . views _submissionGroupName toWidget
|
|
]
|
|
|
|
validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course"]
|
|
dbtSorting = Map.fromList
|
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
|
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
|
|
, ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
|
]
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
|
in dbTableWidget' validator DBTable{..}
|
|
|
|
|
|
mkCorrectionsTable :: UserId -> DB Widget
|
|
mkCorrectionsTable =
|
|
let dbtIdent = "corrections" :: Text
|
|
dbtStyle = def
|
|
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
|
withType = id
|
|
|
|
corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
|
|
|
corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
|
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
|
|
|
|
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
|
|
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
let crse = ( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
)
|
|
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
|
dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
|
|
|
|
dbtProj = dbtProjId
|
|
<&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
|
<&> _dbrOutput . _2 %~ E.unValue
|
|
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
|
termCellCL <$> view (_dbrOutput . _1)
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
|
|
schoolCellCL <$> view (_dbrOutput . _1)
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $
|
|
courseCellCL <$> view (_dbrOutput . _1)
|
|
, sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $
|
|
sheetCell <$> view _1 <*> view _2
|
|
, sortable (Just "cstate") (i18nCell MsgTableCorState) $
|
|
correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
|
|
, sortable (toNothing "cload") (i18nCell MsgTableCorProportion) $
|
|
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
|
|
, sortable (toNothing "assigned") (i18nCell MsgTableCorProportion) $
|
|
int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
|
|
, sortable (toNothing "corrected") (i18nCell MsgTableCorProportion) $
|
|
int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
|
|
]
|
|
|
|
validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
|
|
dbtSorting = Map.fromList
|
|
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
|
|
, ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
|
|
, ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName )
|
|
, ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorState )
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
|
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
|
]
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
|
in dbTableWidget' validator DBTable{..}
|
|
|
|
|
|
-- | Table listing all qualifications that the given user is enrolled in
|
|
mkQualificationsTable :: UTCTime -> UserId -> DB Widget
|
|
mkQualificationsTable =
|
|
let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a)
|
|
-> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a)
|
|
withType = id
|
|
validator = def & defaultSorting [SortAscBy "valid-until", SortAscBy "quali"]
|
|
in \now uid -> dbTableWidget' validator
|
|
DBTable
|
|
{ dbtIdent = "userQualifications" :: Text
|
|
, dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
|
|
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
|
|
E.&&. qblock `isLatestBlockBefore` E.val now
|
|
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
|
|
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
|
|
return (quali, quser, qblock)
|
|
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
|
|
, dbtProj = dbtProjId
|
|
, dbtColonnade = mconcat
|
|
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
|
|
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
|
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
|
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
|
|
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
|
|
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
|
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
|
|
]
|
|
, dbtSorting = mconcat
|
|
[ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
|
|
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
|
|
, singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
|
|
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil
|
|
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh
|
|
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
|
|
]
|
|
, dbtFilter = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
|
|
|
|
getAuthPredsR, postAuthPredsR :: Handler Html
|
|
getAuthPredsR = postAuthPredsR
|
|
postAuthPredsR = do
|
|
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
|
|
|
let
|
|
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
|
|
taForm authTag
|
|
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
|
|
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
|
|
|
|
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
|
<$> apopt checkBoxField (fslI MsgActiveAuthTagsSaveCookie & setTooltip MsgActiveAuthTagsSaveCookieTip) (Just False)
|
|
<*> fmap AuthTagActive (funcForm taForm (fslI MsgActiveAuthTags) True)
|
|
|
|
mReferer <- runMaybeT $ do
|
|
param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
|
|
MaybeT . return $ fromPathPiece param
|
|
|
|
let authActiveForm = wrapForm authActiveWidget' def
|
|
{ formAction = Just $ SomeRoute AuthPredsR
|
|
, formEncoding = authActiveEnctype
|
|
, formSubmit = FormDualSubmit
|
|
}
|
|
authActiveWidget'
|
|
= [whamlet|
|
|
$newline never
|
|
$maybe referer <- mReferer
|
|
<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} <- runDB $
|
|
get404 uid
|
|
|
|
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $
|
|
notificationForm (Just userNotificationSettings)
|
|
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 -> do
|
|
lift . runDB $ do
|
|
update uid [ UserNotificationSettings =. ns ]
|
|
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
|
|
|
|
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
|
|
setTitleI $ MsgNotificationSettingsHeading userDisplayName
|
|
formWidget
|
|
|
|
|
|
data ButtonSetDisplayEmail = BtnSetDisplayEmail
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
instance Universe ButtonSetDisplayEmail
|
|
instance Finite ButtonSetDisplayEmail
|
|
|
|
nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id
|
|
|
|
instance Button UniWorX ButtonSetDisplayEmail where
|
|
btnClasses _ = [BCIsButton]
|
|
|
|
|
|
getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
|
|
getSetDisplayEmailR = postSetDisplayEmailR
|
|
postSetDisplayEmailR = do
|
|
uid <- requireAuthId
|
|
mDisplayEmail <- requireCurrentBearerRestrictions
|
|
|
|
case mDisplayEmail of
|
|
Nothing -> invalidArgs ["Bearer token required"]
|
|
Just displayEmail -> do
|
|
((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm
|
|
let btnView' = wrapForm btnView def
|
|
{ formSubmit = FormNoSubmit
|
|
, formAction = Just $ SomeRoute SetDisplayEmailR
|
|
, formEncoding = btnEnc
|
|
}
|
|
|
|
formResult btnRes $ \case
|
|
BtnSetDisplayEmail -> do
|
|
runDB $
|
|
update uid [UserDisplayEmail =. displayEmail]
|
|
addMessageI Success MsgUserDisplayEmailChanged
|
|
redirect ProfileR
|
|
|
|
siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do
|
|
setTitleI MsgTitleChangeUserDisplayEmail
|
|
$(i18nWidgetFile "set-display-email")
|
|
|
|
getCsvOptionsR, postCsvOptionsR :: Handler Html
|
|
getCsvOptionsR = postCsvOptionsR
|
|
postCsvOptionsR = do
|
|
Entity uid User{userCsvOptions} <- requireAuth
|
|
|
|
userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
|
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
|
|
E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
|
|
E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
|
|
return $ examOfficeLabel E.^. ExamOfficeLabelName
|
|
|
|
((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
|
|
csvOptionsForm (Just userCsvOptions) (Set.fromList $ E.unValue <$> examOfficeLabels)
|
|
|
|
formResultModal optionsRes CsvOptionsR $ \opts -> do
|
|
lift . runDB $ update uid [ UserCsvOptions =. opts ]
|
|
tell . pure =<< messageI Success MsgCsvOptionsUpdated
|
|
|
|
siteLayoutMsg MsgCsvOptions $ do
|
|
setTitleI MsgCsvOptions
|
|
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
wrapForm optionsWgt' def
|
|
{ formAction = Just $ SomeRoute CsvOptionsR
|
|
, formEncoding = optionsEnctype
|
|
, formAttrs = [ asyncSubmitAttr | isModal ]
|
|
}
|
|
|
|
postLangR :: Handler Void
|
|
postLangR = do
|
|
requestedLang <- selectLanguage' appLanguages . hoistMaybe <$> lookupGlobalPostParam PostLanguage
|
|
lang' <- runDB . updateUserLanguage $ Just requestedLang
|
|
|
|
app <- getYesod
|
|
let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang''
|
|
| otherwise = renderMessage app []
|
|
addMessage Success . toHtml $ mr MsgLanguageChanged
|
|
|
|
redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer
|