719 lines
38 KiB
Haskell
719 lines
38 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>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Exam.Form
|
|
( ExamForm(..)
|
|
, ExamOccurrenceForm(..)
|
|
, ExamPartForm(..)
|
|
, examForm
|
|
, examOccurrenceMultiForm, examOccurrenceForm
|
|
, upsertExamOccurrences, copyExamOccurrences
|
|
, examFormTemplate, examTemplate
|
|
, validateExam
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Exam.CorrectorInvite ()
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
import Handler.Utils.Exam (evalExamModeDNF)
|
|
|
|
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.Experimental as Ex
|
|
import qualified Database.Esqueleto.Utils as Ex
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
import Text.Pandoc.Shared (toRomanNumeral)
|
|
import qualified Data.Char as Char
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as LT
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
data ExamForm = ExamForm
|
|
{ efName :: ExamName
|
|
, efDescription :: Maybe StoredMarkup
|
|
, efStart :: Maybe UTCTime
|
|
, efEnd :: Maybe UTCTime
|
|
, efVisibleFrom :: Maybe UTCTime
|
|
, efRegisterFrom :: Maybe UTCTime
|
|
, efRegisterTo :: Maybe UTCTime
|
|
, efDeregisterUntil :: Maybe UTCTime
|
|
, efPublishOccurrenceAssignments :: Maybe UTCTime
|
|
, efPartsFrom :: Maybe UTCTime
|
|
, efFinished :: Maybe UTCTime
|
|
, efOccurrences :: Set ExamOccurrenceForm
|
|
, efPublicStatistics :: Bool
|
|
, efGradingRule :: Maybe ExamGradingRule
|
|
, efBonusRule :: Maybe ExamBonusRule
|
|
, efOccurrenceRule :: ExamOccurrenceRule
|
|
, efExamMode :: ExamMode
|
|
, efGradingMode :: ExamGradingMode
|
|
, efOfficeSchools :: Set SchoolId
|
|
, efStaff :: Maybe Text
|
|
, efCorrectors :: Set (Either UserEmail UserId)
|
|
, efExamParts :: Set ExamPartForm
|
|
, efAuthorshipStatement :: Maybe I18nStoredMarkup
|
|
}
|
|
|
|
data ExamOccurrenceForm = ExamOccurrenceForm
|
|
{ eofId :: Maybe CryptoUUIDExamOccurrence
|
|
, eofName :: Maybe ExamOccurrenceName
|
|
, eofExaminer :: Maybe UserId
|
|
, eofRoom :: Maybe RoomReference
|
|
, eofRoomHidden :: Bool
|
|
, eofCapacity :: Maybe Word64
|
|
, eofStart :: UTCTime
|
|
, eofEnd :: Maybe UTCTime
|
|
, eofDescription :: Maybe StoredMarkup
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance Ord ExamOccurrenceForm where
|
|
compare = mconcat
|
|
[ comparing eofName
|
|
, comparing eofStart
|
|
, comparing eofExaminer
|
|
, comparing eofRoom
|
|
, comparing eofEnd
|
|
, comparing eofCapacity
|
|
, comparing eofDescription
|
|
, comparing eofRoomHidden
|
|
, comparing eofId
|
|
]
|
|
|
|
data ExamPartForm = ExamPartForm
|
|
{ epfId :: Maybe CryptoUUIDExamPart
|
|
, epfNumber :: ExamPartNumber
|
|
, epfName :: Maybe ExamPartName
|
|
, epfMaxPoints :: Maybe Points
|
|
, epfWeight :: Rational
|
|
} deriving (Read, Show, Eq, Generic)
|
|
|
|
instance Ord ExamPartForm where
|
|
compare = mconcat
|
|
[ comparing epfNumber
|
|
, comparing epfName
|
|
, comparing epfMaxPoints
|
|
, comparing epfWeight
|
|
, comparing epfId
|
|
]
|
|
|
|
makeLenses_ ''ExamForm
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''ExamPartForm
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''ExamOccurrenceForm
|
|
|
|
|
|
examForm :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Entity Course -> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
|
|
examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
|
|
mr'@(MsgRenderer mr) <- getMsgRenderer
|
|
(School{..}, mSchoolAuthorshipStatement) <- liftHandler . runDBRead $ do
|
|
school@School{..} <- getJust courseSchool
|
|
mSchoolAuthorshipStatement <- maybe (pure Nothing) getEntity schoolSheetExamAuthorshipStatementDefinition
|
|
return (school, mSchoolAuthorshipStatement)
|
|
|
|
flip (renderAForm FormStandard) csrf $ ExamForm
|
|
<$> areq ciField (fslpI MsgTableExamName (mr MsgTableExamName) & setTooltip MsgExamNameTip) (efName <$> template)
|
|
<*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template)
|
|
<* aformSection MsgExamFormTimes
|
|
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip (someMessages [MsgExamTimeTip,MsgExamTimeFilterTip])) (efStart <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip (someMessages [MsgExamTimeTip,MsgExamTimeFilterTip])) (efEnd <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip ) (efVisibleFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamPartsFrom (mr MsgDate) & setTooltip MsgExamPartsFromTip) (efPartsFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
|
|
<* aformSection MsgExamFormOccurrences
|
|
<*> examOccurrenceMultiForm (efOccurrences <$> template)
|
|
<* aformSection MsgExamFormAutomaticFunctions
|
|
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
|
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
|
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
|
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
|
<* aformSection MsgExamFormMode
|
|
<*> examModeForm (efExamMode <$> template)
|
|
<* aformSection MsgExamFormGrades
|
|
<*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed)
|
|
<*> officeSchoolsForm (efOfficeSchools <$> template)
|
|
<*> apreq' (textField & cfStrip) (fslpI MsgExamStaff (mr MsgExamStaff) & setTooltip MsgExamStaffTip) (efStaff <$> template)
|
|
<* aformSection MsgExamFormCorrection
|
|
<*> examCorrectorsForm (efCorrectors <$> template)
|
|
<* aformSection MsgExamFormParts
|
|
<*> examPartsForm (efExamParts <$> template)
|
|
<*> let
|
|
reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler I18nStoredMarkup
|
|
reqContentField ttip = fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent)
|
|
$ i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
|
|
(fslI MsgSheetAuthorshipStatementContent & ttip)
|
|
True
|
|
( fmap Just $ (efAuthorshipStatement =<< template)
|
|
<|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
|
|
)
|
|
forcedContentField = aforced forcedAuthorshipStatementField
|
|
(fslI MsgExamAuthorshipStatementContent & setTooltip MsgExamAuthorshipStatementContentForcedTip)
|
|
contentField ttipReq
|
|
| not schoolSheetExamAuthorshipStatementAllowOther
|
|
= fmap (fmap authorshipStatementDefinitionContent) (traverse (forcedContentField . entityVal) mSchoolAuthorshipStatement)
|
|
| otherwise
|
|
= Just <$> reqContentField ttipReq
|
|
in case schoolSheetExamAuthorshipStatementMode of
|
|
SchoolAuthorshipStatementModeNone -> pure Nothing -- suppress display of whole section incl. header
|
|
otherMode -> aformSection MsgExamAuthorshipStatementSection
|
|
*> case otherMode of
|
|
SchoolAuthorshipStatementModeOptional -> optionalActionA (fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent) $ contentField id)
|
|
(fslI MsgExamAuthorshipStatementRequired & setTooltip MsgExamAuthorshipStatementRequiredTip)
|
|
((is _Just . efAuthorshipStatement <$> template) <|> Just (is _Just mSchoolAuthorshipStatement))
|
|
SchoolAuthorshipStatementModeRequired -> contentField $ setTooltip MsgExamAuthorshipStatementRequiredForcedTip
|
|
_none -> pure Nothing
|
|
|
|
officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
|
|
officeSchoolsForm mPrev = wFormToAForm $ do
|
|
currentRoute <- fromMaybe (error "officeSchoolsForm called from 404-handler") <$> getCurrentRoute
|
|
|
|
let
|
|
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([SchoolId] -> FormResult [SchoolId])
|
|
miAdd' nudge submitView csrf = do
|
|
(schoolRes, addView) <- mpopt schoolField ("" & addName (nudge "school")) Nothing
|
|
let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat)
|
|
return (schoolRes', $(widgetFile "exam/schoolMassInput/add"))
|
|
|
|
miCell' :: SchoolId -> Widget
|
|
miCell' ssh = do
|
|
School{..} <- liftHandler . runDB $ getJust ssh
|
|
$(widgetFile "exam/schoolMassInput/cell")
|
|
|
|
miLayout' :: MassInputLayout ListLength SchoolId ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "exam/schoolMassInput/layout")
|
|
|
|
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("exam-schools" :: Text) (fslI MsgExamExamOfficeSchools & setTooltip MsgExamExamOfficeSchoolsTip) False (Set.toList <$> mPrev)
|
|
|
|
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
|
|
examCorrectorsForm mPrev = wFormToAForm $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
|
|
uid <- liftHandler requireAuthId
|
|
|
|
let
|
|
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
|
miAdd' nudge submitView csrf = do
|
|
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
|
let
|
|
addRes'
|
|
|
|
= addRes <&> \newDat oldDat -> if
|
|
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgExamCorrectorAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ Set.toList newDat
|
|
return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add"))
|
|
|
|
corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User))
|
|
corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do
|
|
E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser
|
|
E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
|
|
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
return corrUser
|
|
|
|
|
|
miCell' :: Either UserEmail UserId -> Widget
|
|
miCell' (Left email) = do
|
|
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
|
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
|
|
miCell' (Right userId) = do
|
|
usr <- liftHandler . runDB $ get404 userId
|
|
$(widgetFile "widgets/massinput/examCorrectors/cellKnown")
|
|
|
|
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
|
|
|
|
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgExamCorrectorsTip) False (Set.toList <$> mPrev)
|
|
|
|
|
|
examOccurrenceForm :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm
|
|
examOccurrenceForm nudge mPrev csrf = do
|
|
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
|
|
(eofNameRes, eofNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
|
|
(eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions!
|
|
(eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,)
|
|
<$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev)
|
|
<*> apopt checkBoxField (fslI MsgExamRoomRoomHidden & setTooltip MsgExamRoomRoomHiddenTip & addName (nudge "room-hidden")) (eofRoomHidden <$> mPrev)
|
|
let eofRoomRes = view _1 <$> eofRoomRes'
|
|
eofRoomHiddenRes = view _2 <$> eofRoomRes'
|
|
(eofCapacityRes, eofCapacityView) <- mopt (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev)
|
|
(eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev)
|
|
(eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev)
|
|
(eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)
|
|
return ( ExamOccurrenceForm
|
|
<$> eofIdRes
|
|
<*> eofNameRes
|
|
<*> eofExaminerRes
|
|
<*> eofRoomRes
|
|
<*> eofRoomHiddenRes
|
|
<*> eofCapacityRes
|
|
<*> eofStartRes
|
|
<*> eofEndRes
|
|
<*> eofDescRes
|
|
, $(widgetFile "widgets/massinput/examRooms/form")
|
|
)
|
|
where
|
|
examinerField = knownUserField True $ Just $ E.from $ \usr -> do
|
|
E.where_ $
|
|
(E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser E.==. usr E.^. UserId
|
|
) E.||.
|
|
(E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer E.==. E.just (usr E.^. UserId)
|
|
)
|
|
pure usr
|
|
|
|
examOccurrenceMultiForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
|
|
examOccurrenceMultiForm prev = wFormToAForm $ do
|
|
currentRoute <- fromMaybe (error "examOccurrenceMultiForm called from 404-handler") <$> getCurrentRoute
|
|
let
|
|
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
|
|
where
|
|
miAdd' nudge submitView csrf = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
(res, formWidget) <- examOccurrenceForm nudge Nothing csrf
|
|
let
|
|
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
|
| newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
|
|
| otherwise -> FormSuccess $ pure newDat
|
|
return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
|
|
miCell' nudge dat = examOccurrenceForm nudge (Just dat)
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
|
|
miIdent' :: Text
|
|
miIdent' = "exam-occurrences"
|
|
|
|
|
|
examOccurrenceTemplate :: ExamOccurrence -> ExamOccurrenceForm
|
|
examOccurrenceTemplate ExamOccurrence{..} = ExamOccurrenceForm{..}
|
|
where
|
|
eofId = Nothing
|
|
eofName = Just examOccurrenceName
|
|
eofExaminer = examOccurrenceExaminer
|
|
eofRoom = examOccurrenceRoom
|
|
eofRoomHidden = examOccurrenceRoomHidden
|
|
eofCapacity = examOccurrenceCapacity
|
|
eofStart = examOccurrenceStart
|
|
eofEnd = examOccurrenceEnd
|
|
eofDescription = examOccurrenceDescription
|
|
|
|
-- | copy all exam occurrences of an exam, that start on a specified day, to another day, preserving everything else
|
|
-- if the occurrence name contains the day it is replaced, otherwise guessExamOccurrenceName is invoked
|
|
copyExamOccurrences :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend
|
|
, PersistUniqueWrite backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
|
|
, MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
|
|
=> Key Exam -> Day -> Day -> ReaderT backend m Int
|
|
copyExamOccurrences eId dfrom dto = do
|
|
let dfts = ["%d.%m.%Y", "%d.%m.%y", "%Y-%m-%d", "%y-%m-%d", "%d.%m", "%d-%m", "%m-%d"]
|
|
fts fs = (,) <$> formatTime' fs dfrom <*> formatTime' fs dto
|
|
shiftDay :: Day -> Day = addDays $ diffDays dto dfrom
|
|
drepl <- mapM fts dfts
|
|
exOccs <- Ex.select $ do
|
|
occ <- Ex.from $ Ex.table @ExamOccurrence
|
|
Ex.where_ $ occ Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId
|
|
Ex.&&. Ex.day (occ Ex.^. ExamOccurrenceStart) Ex.==. Ex.val dfrom
|
|
return occ
|
|
res <- forM exOccs $ \Entity{entityVal=eo@ExamOccurrence{examOccurrenceName=oldName}} -> do
|
|
let eo' = _examOccurrenceStart . _utctDay %~ shiftDay $
|
|
_examOccurrenceEnd . _Just . _utctDay %~ shiftDay $ eo
|
|
newName <- maybeM (guessExamOccurrenceName eId $ examOccurrenceTemplate eo') return $ return (fmap CI.mk $ textReplaceFirst drepl $ CI.original oldName)
|
|
insertUnique_ (eo'{examOccurrenceName=newName})
|
|
memcachedInvalidateClass MemcachedKeyClassExamOccurrences
|
|
return $ length $ catMaybes res
|
|
|
|
-- | generate an exam-unique occurrence name from data
|
|
-- Pattern: <initials-examiner>_<mm-dd>_<room>_<roman_numeral>
|
|
-- eofName is entirely ignored, assumed to be Nothing
|
|
guessExamOccurrenceName :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
|
|
, MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
|
|
=> Key Exam -> ExamOccurrenceForm -> ReaderT backend m ExamOccurrenceName
|
|
guessExamOccurrenceName eId ExamOccurrenceForm{..} = do
|
|
-- oday <- formatTime' "%m-%d" eofStart
|
|
oday <- formatTime' "%d.%m." eofStart
|
|
ohour <- ifM hasMoreThanOneHour (formatTime' "at%H" eofStart) (return mempty)
|
|
inis <- ifMoreThanOne ExamOccurrenceExaminer $ foldMapM getInitials eofExaminer
|
|
room <- case eofRoom of
|
|
Just (RoomReferenceSimple t) -> ifMoreThanOne ExamOccurrenceRoom $ return $ Text.take 4 t -- Text.cons '-' $ Text.take 4 t
|
|
_ -> return mempty
|
|
let pfx = CI.mk $ inis <> oday <> ohour <> room
|
|
eons = ocheck pfx : [ ocheck $ pfx <> CI.mk (Text.cons '_' $ toRomanNumeral n) | n <- [2..3999]]
|
|
fromMaybe "Handler.Exam.Form.guessExamOccurrenceName failed to guess a unique name"
|
|
<$> firstJustM eons
|
|
where
|
|
getInitials uid = get uid <&> foldMap (Text.filter Char.isUpper . userDisplayName) -- flip Text.snoc '_' .
|
|
ocheck eon = existsBy (UniqueExamOccurrence eId eon) <&> (flip toMaybe eon . not)
|
|
|
|
ifMoreThanOne :: (PersistField t, Monoid o) => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m o -> ReaderT backend m o
|
|
ifMoreThanOne eoprop act = ifM (hasMoreThanOne eoprop) act (return mempty)
|
|
|
|
hasMoreThanOne :: PersistField t => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m Bool
|
|
hasMoreThanOne eoprop = $(memcachedByHere) (Just . Right $ 1 * diffMinute) (eId, tshow $ persistFieldDef eoprop) $ Ex.selectExists $ do
|
|
exOcc <- Ex.from $ Ex.table @ExamOccurrence
|
|
Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
|
|
Ex.&&. Ex.isJust (exOcc Ex.^. eoprop)
|
|
Ex.&&. Ex.exists (do
|
|
otOcc <- Ex.from $ Ex.table @ExamOccurrence
|
|
Ex.where_ $ (otOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
|
|
Ex.&&. Ex.isJust (otOcc Ex.^. eoprop)
|
|
Ex.&&. otOcc Ex.^. eoprop Ex.!=. exOcc Ex.^. eoprop
|
|
)
|
|
|
|
hasMoreThanOneHour :: ReaderT backend m Bool
|
|
hasMoreThanOneHour = $(memcachedByHere) (Just . Right $ 1 * diffMinute) eId $ Ex.selectExists $ do
|
|
exOcc <- Ex.from $ Ex.table @ExamOccurrence
|
|
Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
|
|
Ex.&&. Ex.exists (do
|
|
other <- Ex.from $ Ex.table @ExamOccurrence
|
|
Ex.where_ $ (other Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
|
|
Ex.&&. (Ex.day (other Ex.^. ExamOccurrenceStart) Ex.==. Ex.day (exOcc Ex.^. ExamOccurrenceStart))
|
|
Ex.&&. ( other Ex.^. ExamOccurrenceStart Ex.!=. exOcc Ex.^. ExamOccurrenceStart)
|
|
)
|
|
|
|
|
|
-- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB () -- too specific
|
|
upsertExamOccurrences :: ( HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m
|
|
, PersistQueryRead backend, PersistUniqueWrite backend
|
|
, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
|
|
=> Key Exam -> [ExamOccurrenceForm] -> ReaderT backend m Int
|
|
upsertExamOccurrences eId = fmap (length . catMaybes) . mapM (\case
|
|
eof@ExamOccurrenceForm{ eofId = Nothing, eofName = eofNameMb, .. } -> do
|
|
eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
|
|
$logInfoS "ExamOccurrenceForm" [st|New Exam Occurrence: #{eofName}|]
|
|
insertUnique_ ExamOccurrence
|
|
{ examOccurrenceExam = eId
|
|
, examOccurrenceName = eofName
|
|
, examOccurrenceExaminer = eofExaminer
|
|
, examOccurrenceRoom = eofRoom
|
|
, examOccurrenceRoomHidden = eofRoomHidden
|
|
, examOccurrenceCapacity = eofCapacity
|
|
, examOccurrenceStart = eofStart
|
|
, examOccurrenceEnd = eofEnd
|
|
, examOccurrenceDescription = eofDescription
|
|
}
|
|
eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> fmap join $ runMaybeT $ do
|
|
cID <- hoistMaybe eofId
|
|
eofId' <- decrypt cID
|
|
oldOcc <- MaybeT $ get eofId'
|
|
guard $ examOccurrenceExam oldOcc == eId
|
|
lift $ do
|
|
eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
|
|
res <- replaceUnique eofId' ExamOccurrence
|
|
{ examOccurrenceExam = eId
|
|
, examOccurrenceName = eofName
|
|
, examOccurrenceExaminer = eofExaminer
|
|
, examOccurrenceRoom = eofRoom
|
|
, examOccurrenceRoomHidden = eofRoomHidden
|
|
, examOccurrenceCapacity = eofCapacity
|
|
, examOccurrenceStart = eofStart
|
|
, examOccurrenceEnd = eofEnd
|
|
, examOccurrenceDescription = eofDescription
|
|
}
|
|
memcachedInvalidateClass MemcachedKeyClassExamOccurrences
|
|
return $ flipMaybe () res
|
|
)
|
|
|
|
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
|
|
examPartsForm prev = wFormToAForm $ do
|
|
currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
|
|
let
|
|
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev
|
|
where
|
|
examPartForm' nudge mPrev csrf = do
|
|
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
|
|
(epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
|
|
(epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev)
|
|
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
|
|
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) (fslI MsgExamPartWeight & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
|
|
|
|
return ( ExamPartForm
|
|
<$> epfIdRes
|
|
<*> epfNumberRes
|
|
<*> epfNameRes
|
|
<*> epfMaxPointsRes
|
|
<*> epfWeightRes
|
|
, $(widgetFile "widgets/massinput/examParts/form")
|
|
)
|
|
|
|
miAdd' nudge submitView csrf = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
|
let
|
|
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
|
| any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
|
|
-> FormFailure [mr MsgExamPartAlreadyExists]
|
|
| otherwise -> FormSuccess $ pure newDat
|
|
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
|
miCell' nudge dat = examPartForm' nudge (Just dat)
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
|
|
miIdent' :: Text
|
|
miIdent' = "exam-parts"
|
|
|
|
examFormTemplate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
|
)
|
|
=> Entity Exam -> SqlPersistT m ExamForm
|
|
examFormTemplate (Entity eId Exam{..}) = do
|
|
examParts <- selectList [ ExamPartExam ==. eId ] []
|
|
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
|
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
|
|
invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId
|
|
extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] []
|
|
|
|
examParts' <- lift . forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
|
occurrences' <- lift . forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
|
|
|
|
mAuthorshipStatement <- maybe (pure Nothing) getEntity examAuthorshipStatement
|
|
|
|
return ExamForm
|
|
{ efName = examName
|
|
, efGradingRule = examGradingRule
|
|
, efBonusRule = examBonusRule
|
|
, efOccurrenceRule = examOccurrenceRule
|
|
, efVisibleFrom = examVisibleFrom
|
|
, efRegisterFrom = examRegisterFrom
|
|
, efRegisterTo = examRegisterTo
|
|
, efDeregisterUntil = examDeregisterUntil
|
|
, efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
|
|
, efPartsFrom = examPartsFrom
|
|
, efStart = examStart
|
|
, efEnd = examEnd
|
|
, efFinished = examFinished
|
|
, efGradingMode = examGradingMode
|
|
, efPublicStatistics = examPublicStatistics
|
|
, efDescription = examDescription
|
|
, efOccurrences = Set.fromList $ do
|
|
(Just -> eofId, ExamOccurrence{..}) <- occurrences'
|
|
return ExamOccurrenceForm
|
|
{ eofId
|
|
, eofName = examOccurrenceName & Just
|
|
, eofExaminer = examOccurrenceExaminer
|
|
, eofRoom = examOccurrenceRoom
|
|
, eofRoomHidden = examOccurrenceRoomHidden
|
|
, eofCapacity = examOccurrenceCapacity
|
|
, eofStart = examOccurrenceStart
|
|
, eofEnd = examOccurrenceEnd
|
|
, eofDescription = examOccurrenceDescription
|
|
}
|
|
, efExamParts = Set.fromList $ do
|
|
(Just -> epfId, ExamPart{..}) <- examParts'
|
|
return ExamPartForm
|
|
{ epfId
|
|
, epfNumber = examPartNumber
|
|
, epfName = examPartName
|
|
, epfMaxPoints = examPartMaxPoints
|
|
, epfWeight = examPartWeight
|
|
}
|
|
, efCorrectors = Set.unions
|
|
[ Set.mapMonotonic Left invitations
|
|
, Set.fromList . map Right $ do
|
|
Entity _ ExamCorrector{..} <- correctors
|
|
return examCorrectorUser
|
|
]
|
|
, efExamMode = examExamMode
|
|
, efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
|
|
, efStaff = examStaff
|
|
, efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mAuthorshipStatement
|
|
}
|
|
|
|
examTemplate :: MonadHandler m
|
|
=> CourseId -> SqlPersistT m (Maybe ExamForm)
|
|
examTemplate cid = runMaybeT $ do
|
|
newCourse <- MaybeT $ get cid
|
|
|
|
[(Entity _ oldCourse, Entity oldExamId oldExam, mOldExamAuthorshipStatement)] <- lift . E.select . E.from $ \(course `E.InnerJoin` (exam `E.LeftOuterJoin` authorshipStatementDefinition)) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.on $ exam E.^. ExamAuthorshipStatement E.==. authorshipStatementDefinition E.?. AuthorshipStatementDefinitionId
|
|
E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
|
|
E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
|
|
)
|
|
E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
|
|
E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
|
|
E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
|
|
E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
|
|
E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
|
|
E.limit 1
|
|
E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
|
|
return (course, exam, authorshipStatementDefinition)
|
|
|
|
extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []
|
|
|
|
oldTerm <- MaybeT . get $ courseTerm oldCourse
|
|
newTerm <- MaybeT . get $ courseTerm newCourse
|
|
|
|
let
|
|
dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm
|
|
|
|
return ExamForm
|
|
{ efName = examName oldExam
|
|
, efGradingRule = examGradingRule oldExam
|
|
, efBonusRule = examBonusRule oldExam
|
|
, efOccurrenceRule = examOccurrenceRule oldExam
|
|
, efVisibleFrom = dateOffset <$> examVisibleFrom oldExam
|
|
, efRegisterFrom = dateOffset <$> examRegisterFrom oldExam
|
|
, efRegisterTo = dateOffset <$> examRegisterTo oldExam
|
|
, efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam
|
|
, efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
|
|
, efPartsFrom = dateOffset <$> examPartsFrom oldExam
|
|
, efStart = dateOffset <$> examStart oldExam
|
|
, efEnd = dateOffset <$> examEnd oldExam
|
|
, efFinished = dateOffset <$> examFinished oldExam
|
|
, efGradingMode = examGradingMode oldExam
|
|
, efPublicStatistics = examPublicStatistics oldExam
|
|
, efDescription = examDescription oldExam
|
|
, efOccurrences = Set.empty
|
|
, efExamParts = Set.empty
|
|
, efCorrectors = Set.empty
|
|
, efExamMode = examExamMode oldExam
|
|
, efStaff = examStaff oldExam
|
|
, efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
|
|
, efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mOldExamAuthorshipStatement
|
|
}
|
|
|
|
|
|
validateExam :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadSite UniWorX (SqlPersistT m)
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
)
|
|
=> CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) ()
|
|
validateExam cId oldExam = do
|
|
ExamForm{..} <- State.get
|
|
|
|
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
|
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
|
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
|
|
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
|
warnValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
|
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
|
guardValidation MsgExamPartsFromMustBeBeforeFinished $ NTop efFinished >= NTop efPartsFrom
|
|
|| is _Nothing efPartsFrom
|
|
|
|
forM_ efOccurrences $ \ExamOccurrenceForm{eofName=fold->eofName, ..} -> do
|
|
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
|
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
|
|
warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
|
|
|
|
forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
|
|
eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
guardValidation (MsgExamOccurrenceDuplicate (maybe (mr MsgExamOccurrenceRoomIsUnset) roomReferenceText $ eofRoom a) eofRange') $ any (\f -> f a b)
|
|
[ (/=) `on` eofRoom
|
|
, (/=) `on` eofStart
|
|
, (/=) `on` eofEnd
|
|
, (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription
|
|
]
|
|
|
|
guardValidation (MsgExamOccurrenceDuplicateName $ fold $ eofName a) $ ((/=) `on` eofName) a b
|
|
|
|
oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do
|
|
E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
|
|
E.where_ . E.exists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
|
|
return ( examOccurrence E.^. ExamOccurrenceId
|
|
, examOccurrence E.^. ExamOccurrenceName
|
|
)
|
|
forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) ->
|
|
guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . lift . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId
|
|
|
|
|
|
oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do
|
|
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
|
|
E.where_ . E.exists . E.from $ \examPartResult ->
|
|
E.where_ $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
|
|
return ( examPart E.^. ExamPartId
|
|
, examPart E.^. ExamPartNumber
|
|
)
|
|
forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) -> do
|
|
guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId
|
|
runConduit $ transPipe lift (selectSource [] [])
|
|
.| C.filter (has $ _entityVal . _sheetType . _examPart . re _SqlKey . only epId)
|
|
.| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId)
|
|
|
|
|
|
mSchool <- liftHandler . runDB . E.selectOne . E.from $ \(course `E.InnerJoin` school) -> do
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
E.where_ $ course E.^. CourseId E.==. E.val cId
|
|
return school
|
|
|
|
whenIsJust mSchool $ \(Entity _ School{..}) -> do
|
|
whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
|
|
let doValidation
|
|
| Just (Entity _ Exam{..}) <- oldExam
|
|
, not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
|
|
= warnValidation
|
|
| otherwise
|
|
= guardValidation
|
|
doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay)
|
|
. fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
|
|
whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
|
|
let doValidation
|
|
| Just (Entity _ Exam{..}) <- oldExam
|
|
, not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
|
|
= warnValidation
|
|
| otherwise
|
|
= guardValidation
|
|
doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay)
|
|
. fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
|
|
when schoolExamRequireModeForRegistration $ do
|
|
let doValidation
|
|
| Just (Entity _ Exam{ examExamMode = ExamMode{..}, .. }) <- oldExam
|
|
, or [ is _Nothing examAids
|
|
, is _Nothing examOnline
|
|
, is _Nothing examSynchronicity
|
|
, is _Nothing examRequiredEquipment
|
|
]
|
|
, is _Just examRegisterFrom
|
|
= warnValidation
|
|
| otherwise
|
|
= guardValidation
|
|
let ExamMode{..} = efExamMode
|
|
doValidation MsgExamModeRequiredForRegistration
|
|
$ is _Nothing efRegisterFrom
|
|
|| and [ is _Just examAids
|
|
, is _Just examOnline
|
|
, is _Just examSynchronicity
|
|
, is _Just examRequiredEquipment
|
|
]
|
|
|
|
warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode
|
|
|
|
unless (has (_Just . _entityVal . _examStaff . _Nothing) oldExam) $
|
|
guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff
|