267 lines
14 KiB
Haskell
267 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications, BlockArguments #-}
|
|
|
|
module Handler.Tutorial.Users
|
|
( getTUsersR, postTUsersR
|
|
) where
|
|
|
|
import Import
|
|
import Control.Monad.Zip (munzip)
|
|
|
|
import Utils.Form
|
|
import Utils.Print
|
|
import Handler.Utils
|
|
import Handler.Utils.Course
|
|
import Handler.Utils.Course.Cache
|
|
import Handler.Utils.Tutorial
|
|
import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences)
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
-- import qualified Data.Text as Text
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
-- import qualified Data.Time.Zones as TZ
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
|
|
import Handler.Course.Users
|
|
|
|
|
|
-- TODO: Idee: MultiAction für jedes Exam, um so die einzelnen Occurrences zu markieren!
|
|
-- Default muss auch entsprechend generiert werden, wenn keine Occurrences für den Tag existieren
|
|
-- Im Form sollten die neuen markiert werden als ungespeichert! Generell wünschenswert für MassInput!
|
|
|
|
|
|
-- | Generate multiForm with one entry for each course exam showing only day-relevant exam occurrences
|
|
mkExamOccurrenceForm :: [(Entity Exam, CryptoUUIDExam, Widget)] -> ExamOccurrenceMap -> Form (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
|
mkExamOccurrenceForm exs eom = renderAForm FormStandard maa
|
|
where
|
|
maa = multiActionA acts (fslI MsgCourseExam) Nothing
|
|
eid2eos = convertExamOccurrenceMap eom
|
|
|
|
acts :: Map Text (AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
|
|
acts = Map.fromList $ map mkAct exs
|
|
|
|
mkAct :: (Entity Exam, CryptoUUIDExam, Widget) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
|
|
mkAct (Entity{entityKey=eId, entityVal=Exam{examName=eName, examDescription=eDescr}}, cueId, ewgt) = (ciOriginal eName,
|
|
let (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
|
|
in (,,)
|
|
<$ for_ eDescr (aformInfoWidget . toWgt)
|
|
<*> apreq hiddenField "" (Just cueId)
|
|
<*> apreq (mkSetField hiddenField) "" cuEoIds
|
|
<* aformInfoWidget ewgt
|
|
<*> examOccurrenceMultiForm eos -- TODO filter occurrences to cuEoIds
|
|
)
|
|
|
|
data TutorialUserAction
|
|
= TutorialUserAssignExam
|
|
| TutorialUserPrintQualification
|
|
| TutorialUserRenewQualification
|
|
| 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
|
|
= TutorialUserPrintQualificationData
|
|
| TutorialUserRenewQualificationData
|
|
{ tuQualification :: QualificationId }
|
|
| TutorialUserGrantQualificationData
|
|
{ tuQualification :: QualificationId
|
|
, tuValidUntil :: Day
|
|
}
|
|
| TutorialUserSendMailData
|
|
| TutorialUserDeregisterData
|
|
| TutorialUserAssignExamData
|
|
{ tuOccurrenceId :: ExamOccurrenceId
|
|
, tuReassign :: Bool
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
|
|
getTUsersR = postTUsersR
|
|
postTUsersR tid ssh csh tutn = do
|
|
let croute = CTutorialR tid ssh csh tutn TUsersR
|
|
now <- liftIO getCurrentTime
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
(cid, Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, timespan, exOccs) <- runDB do
|
|
trm <- get404 tid
|
|
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
-- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
|
(cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn
|
|
qualifications <- getCourseQualifications cid
|
|
let nowaday = utctDay now
|
|
minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays
|
|
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
|
|
colChoices = mconcat $ catMaybes
|
|
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
|
, pure colUserEmail
|
|
, pure $ colUserMatriclenr isAdmin
|
|
, pure $ colUserQualifications nowaday
|
|
, pure $ colUserQualificationBlocked isAdmin nowaday
|
|
, pure $ colUserExamOccurrences tid ssh csh
|
|
, pure $ colUserExams tid ssh csh
|
|
]
|
|
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 do
|
|
tutorialParticipant <- E.from $ E.table @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"]
|
|
qualOptions = qualificationsOptionList qualifications
|
|
lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
|
|
timespan = lessonTimesSpan lessons
|
|
exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
|
|
let
|
|
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
|
acts = Map.fromList $
|
|
bcons (not $ null exOccs)
|
|
( TutorialUserAssignExam
|
|
, TutorialUserAssignExamData
|
|
<$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing
|
|
<*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride) (Just False)
|
|
) $
|
|
(if null qualifications then mempty else
|
|
[ ( TutorialUserRenewQualification
|
|
, TutorialUserRenewQualificationData
|
|
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
|
)
|
|
, ( TutorialUserGrantQualification
|
|
, TutorialUserGrantQualificationData
|
|
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
|
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
|
)
|
|
]
|
|
) ++
|
|
[ ( TutorialUserSendMail , pure TutorialUserSendMailData )
|
|
, ( TutorialUserDeregister , pure TutorialUserDeregisterData )
|
|
, ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
|
|
]
|
|
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
|
|
return (cid, tutEnt, table, qualifications, timespan, exOccs)
|
|
|
|
let courseQids = Set.fromList (entityKey <$> qualifications)
|
|
tcontent <- formResultMaybe participantRes $ \case
|
|
(TutorialUserPrintQualificationData, selectedUsers) -> do
|
|
rcvr <- requireAuth
|
|
encRcvr <- encrypt $ entityKey rcvr
|
|
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
|
|
let mbAletter = anyone letters
|
|
case mbAletter of
|
|
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
|
|
Just aletter -> do
|
|
apcIdent <- letterApcIdent aletter encRcvr now
|
|
let fName = letterFileName aletter
|
|
renderLetters rcvr letters apcIdent >>= \case
|
|
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
|
Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
|
|
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
|
-- let typePDF :: ContentType
|
|
-- typePDF = "application/pdf"
|
|
-- sendResponse (typePDF, toContent pdf)
|
|
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
|
| tuQualification `Set.member` courseQids -> do
|
|
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
|
today <- liftIO getCurrentTime
|
|
let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
|
|
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
|
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
|
reloadKeepGetParams croute
|
|
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
|
| tuQualification `Set.member` courseQids -> do
|
|
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
|
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
|
reloadKeepGetParams croute
|
|
(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
|
|
reloadKeepGetParams croute
|
|
(TutorialUserAssignExamData{..}, selectedUsers)
|
|
| (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
|
|
let n = Set.size selectedUsers
|
|
capOk <- ifNothing examOccurrenceCapacity (pure True) $ \(fromIntegral -> totalCap) -> do
|
|
usedCap <- runDBRead $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. Set.toList selectedUsers]
|
|
let ok = totalCap - usedCap >= n
|
|
unless ok $ addMessageI Error $ MsgExamRommCapacityInsufficient $ totalCap - usedCap
|
|
pure ok
|
|
when capOk do
|
|
let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now
|
|
nrOk <- runDB $ if tuReassign
|
|
then putMany [regTemplate uid | uid <- Set.toList selectedUsers] >> pure n
|
|
else forM (Set.toList selectedUsers) (insertUnique . regTemplate) <&> (length . catMaybes)
|
|
let allok = bool Warning Success $ nrOk == n
|
|
addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk n $ ciOriginal examOccurrenceName
|
|
reloadKeepGetParams croute
|
|
return Nothing
|
|
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
|
|
|
|
case tcontent of
|
|
Just act -> act -- execute action and return produced content
|
|
Nothing -> do -- no table action, continue normally
|
|
let (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
|
|
$logInfoS "ExamOccurrenceForm" [st|Exam from #{tshow tbegin} until #{tshow tend}.|]
|
|
(openExams, tutors) <- runDBRead $ (,)
|
|
<$> selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
|
|
<*> E.select (do
|
|
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
|
`E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
|
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
|
return user
|
|
)
|
|
|
|
let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR
|
|
mkExamEditBtn ename = linkButton mempty (msg2widget MsgMenuExamEdit) [BCIsButton, BCDefault] $ SomeRoute $ CourseR tid ssh csh $ ExamR ename EEditR
|
|
examOccWgt <- if null openExams
|
|
then return $(i18nWidgetFile "exam-missing")
|
|
else do
|
|
openExamsUUIDs <- forM openExams $ \ent@Entity{entityKey=k, entityVal=Exam{examName}} -> (ent,,) <$> encrypt k <*> pure (mkExamEditBtn examName)
|
|
((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO also TODO: occurrence name auto generation
|
|
let gtaAnchor = "general-tutorial-action-form" :: Text
|
|
gtaRoute = croute :#: gtaAnchor
|
|
gtaForm = wrapForm gtaWgt FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ gtaRoute
|
|
, formEncoding = gtaEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just gtaAnchor
|
|
}
|
|
$logInfoS "ExamOccurrenceEdit" $ tshow (Set.map (eofName &&& eofId) . trd3 <$> gtaRes)
|
|
formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
|
let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs
|
|
eId <- decrypt cEId
|
|
eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
|
|
$logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length cEOIds} old occurrences, #{length eoIdsDelete} to delete, #{length $ Set.filter (isNothing . eofId) occs} to insert, #{length $ Set.filter (isJust . eofId) occs} to edit|]
|
|
runDB do
|
|
deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
|
|
upsertExamOccurrences eId $ Set.toList occs
|
|
return gtaForm
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
|
html <- siteLayoutMsg heading do
|
|
setTitleI heading
|
|
$(widgetFile "tutorial-participants")
|
|
return $ toTypedContent html
|