344 lines
17 KiB
Haskell
344 lines
17 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-25 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
|
|
, getTExamR, postTExamR
|
|
) 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, copyExamOccurrences)
|
|
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
|
|
|
|
|
|
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)
|
|
|
|
-- non-table form for general tutorial actions
|
|
data GenTutAction
|
|
= GenTutActOccCopyWeek
|
|
| GenTutActOccCopyLast
|
|
| GenTutActOccEdit
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''GenTutAction id
|
|
|
|
data GenTutActionData
|
|
= GenTutActOccCopyWeekData { gtaExam :: ExamId }
|
|
| GenTutActOccCopyLastData { gtaExam :: ExamId }
|
|
| GenTutActOccEditData { gtaExam :: ExamId }
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
gta2gtad :: GenTutAction -> ExamId -> GenTutActionData
|
|
gta2gtad GenTutActOccCopyWeek = GenTutActOccCopyWeekData
|
|
gta2gtad GenTutActOccCopyLast = GenTutActOccCopyLastData
|
|
gta2gtad GenTutActOccEdit = GenTutActOccEditData
|
|
|
|
|
|
-- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
|
|
-- mkGenTutForm fltr = renderAForm FormStandard maa
|
|
-- where
|
|
-- maa = multiActionA acts (fslI MsgCourseExam) Nothing
|
|
|
|
-- acts :: Map GenTutAction (AForm Handler GenTutActionData)
|
|
-- acts = Map.fromList
|
|
-- [ (GenTutActOccCopy, GenTutActOccCopyData <$> areq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
|
|
-- , (GenTutActOccEdit, GenTutActOccEditData <$> aopt (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
|
|
-- ]
|
|
mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
|
|
mkGenTutForm fltr html = do
|
|
(actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF)) (fslI MsgCourseExam) Nothing
|
|
(exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing
|
|
let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData
|
|
res (FormSuccess gtao) (FormSuccess eid) = FormSuccess $ gta2gtad gtao eid
|
|
res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2
|
|
res (FormFailure e) _ = FormFailure e
|
|
res _ (FormFailure e) = FormFailure e
|
|
res _ _ = FormMissing
|
|
viw = [whamlet|
|
|
<p>
|
|
#{html}^{fvInput actView} _{MsgFor} ^{fvInput exmView}
|
|
|]
|
|
return (res actRes exmRes, viw)
|
|
|
|
|
|
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 (i.e. pdf)
|
|
Nothing -> do -- no table action content to return, continue normally
|
|
let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR
|
|
(dbegin, dend) = munzip timespan
|
|
tbegin = toMidnight . succ <$> dbegin
|
|
tend = toMidnight <$> dend
|
|
exmFltr = ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing]) ++ [ExamCourse ==. cid, ExamStart <=. tend]
|
|
$logInfoS "ExamOccurrenceForm" [st|Exams from #{tshow tbegin} until #{tshow tend}.|]
|
|
((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkGenTutForm exmFltr
|
|
let gtaAnchor = "general-tutorial-action-form" :: Text
|
|
gtaRoute = croute :#: gtaAnchor
|
|
gtaForm = wrapForm' BtnPerform gtaWgt FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ gtaRoute
|
|
, formEncoding = gtaEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just gtaAnchor
|
|
}
|
|
formResult gtaRes $ \case
|
|
GenTutActOccEditData { gtaExam=eId } -> do
|
|
Exam{examName=ename} <- runDBRead $ get404 eId
|
|
redirect $ CTutorialR tid ssh csh tutn $ TExamR ename
|
|
copyAction -> case dbegin of
|
|
Nothing -> addMessageI Error MsgExamOccurrenceCopyNoStartDate
|
|
(Just dto) ->
|
|
let cfailure = addMessageI Error MsgExamOccurrenceCopyFail
|
|
csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute
|
|
copyFrom dfrom = copyExamOccurrences (gtaExam copyAction) dfrom dto <&> (toMaybe =<< (> 0))
|
|
step_dto = case copyAction of
|
|
GenTutActOccCopyWeekData{} -> addDays (-7) dto
|
|
_ -> pred dto
|
|
in maybeM cfailure csuccess $
|
|
runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards
|
|
|
|
tutors <- runDBRead $ 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
|
|
-- $(i18nWidgetFile "exam-missing")
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
|
html <- siteLayoutMsg heading do
|
|
setTitleI heading
|
|
$(widgetFile "tutorial-participants")
|
|
return $ toTypedContent html
|
|
|
|
|
|
getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html
|
|
getTExamR = postTExamR
|
|
postTExamR tid ssh csh tutn exmName = do
|
|
let baseroute = CTutorialR tid ssh csh tutn
|
|
(Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do
|
|
trm <- get404 tid
|
|
(cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn
|
|
exm <- getBy404 $ UniqueExam cid exmName
|
|
let lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
|
|
timespan = lessonTimesSpan lessons
|
|
-- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
|
|
-- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
|
|
exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
|
|
return (exm,exOccs)
|
|
cueId :: CryptoUUIDExam <- encrypt eId
|
|
let eid2eos = convertExamOccurrenceMap exOccs
|
|
(cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
|
|
exOcForm = (,,)
|
|
<$> areq hiddenField "" (Just cueId)
|
|
<*> areq (mkSetField hiddenField) "" cuEoIds
|
|
<*> examOccurrenceMultiForm eos
|
|
((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm
|
|
let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype}
|
|
formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do
|
|
let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs
|
|
$logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|]
|
|
reId <- decrypt edCEId
|
|
eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
|
|
when (reId == eId) $ do
|
|
(fromIntegral -> nrDel, nrUps) <- runDB $ (,)
|
|
<$> deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete]
|
|
<*> upsertExamOccurrences eId (Set.toList edOccs)
|
|
let nr = nrUps + nrDel
|
|
mstat = if nr > 0 then Success else Warning
|
|
addMessageI mstat $ MsgExamOccurrencesEdited nrUps nrDel
|
|
reload $ baseroute $ TExamR exmName
|
|
|
|
let csh_tutn = csh <> "-" <> tutn -- hack to reuse prependCourseTitle
|
|
heading = prependCourseTitle tid ssh csh_tutn $ MsgMenuTutorialExam exmName
|
|
siteLayoutMsg heading do
|
|
-- setTitle $ citext2Html exmName
|
|
setTitleI heading
|
|
[whamlet|
|
|
<section>
|
|
<h2>#{CI.original exmName}
|
|
<p>#{examDescription exm}
|
|
<section>
|
|
^{eofForm}
|
|
|]
|