127 lines
5.4 KiB
Haskell
127 lines
5.4 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Tutorial.Users
|
|
( getTUsersR, postTUsersR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Tutorial
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
-- import qualified Data.Time.Zones as TZ
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import Handler.Course.Users
|
|
|
|
|
|
data TutorialUserAction
|
|
= TutorialUserGrantQualification
|
|
| TutorialUserSendMail
|
|
| TutorialUserDeregister
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
instance Universe TutorialUserAction
|
|
instance Finite TutorialUserAction
|
|
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
|
|
|
data TutorialUserActionData
|
|
= TutorialUserGrantQualificationData
|
|
{ tuQualification :: QualificationId
|
|
, tuValidUntil :: Day
|
|
}
|
|
| TutorialUserSendMailData
|
|
| TutorialUserDeregisterData{}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
|
getTUsersR = postTUsersR
|
|
postTUsersR tid ssh csh tutn = do
|
|
showSex <- getShowSex
|
|
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
|
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
|
qualifications <- selectList [QualificationSchool ==. ssh] []
|
|
now <- liftIO getCurrentTime
|
|
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
|
|
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
|
|
colChoices = mconcat $ catMaybes
|
|
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, pure colUserName
|
|
, guardOn showSex colUserSex'
|
|
, pure colUserEmail
|
|
, pure colUserMatriclenr
|
|
, pure colUserQualifications
|
|
]
|
|
psValidator = def
|
|
& defaultSortingByName
|
|
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
|
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
|
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
|
|
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let
|
|
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
|
qualOpt (Entity qualId qual) = do
|
|
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
|
return $ Option
|
|
{ optionDisplay = CI.original $ qualificationName qual
|
|
, optionInternalValue = qualId
|
|
, optionExternalValue = tshow cQualId
|
|
}
|
|
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
|
acts = Map.fromList
|
|
[ ( TutorialUserGrantQualification
|
|
, TutorialUserGrantQualificationData
|
|
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
|
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
|
)
|
|
, ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
|
, ( TutorialUserDeregister, pure TutorialUserDeregisterData )
|
|
]
|
|
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
|
|
return (tut, table)
|
|
|
|
formResult participantRes $ \case
|
|
(TutorialUserGrantQualificationData{..}, selectedUsers) -> do
|
|
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
|
today <- utctDay <$> liftIO getCurrentTime
|
|
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
|
|
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
|
(TutorialUserSendMailData{}, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(TutorialUserDeregisterData{},selectedUsers) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ TutorialParticipantTutorial ==. tutid
|
|
, TutorialParticipantUser <-. Set.toList selectedUsers
|
|
]
|
|
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
|
|
|
tutors <- runDB $
|
|
E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
|
return user
|
|
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
$(widgetFile "tutorial-participants")
|