refactor(exams): split Handler.Exams & better type for pass/fail
This commit is contained in:
Gregor Kleen
parent
718519fe10
commit
d5be5d61ee
@ -1270,4 +1270,8 @@ ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig ide
|
||||
|
||||
TableHeadingFilter: Filter
|
||||
TableHeadingCsvImport: CSV-Import
|
||||
TableHeadingCsvExport: CSV-Export
|
||||
TableHeadingCsvExport: CSV-Export
|
||||
|
||||
ExamResultAttended: Teilgenommen
|
||||
ExamResultNoShow: Nicht erschienen
|
||||
ExamResultVoided: Entwertet
|
||||
1551
src/Handler/Exam.hs
1551
src/Handler/Exam.hs
File diff suppressed because it is too large
Load Diff
154
src/Handler/Exam/AddUser.hs
Normal file
154
src/Handler/Exam/AddUser.hs
Normal file
@ -0,0 +1,154 @@
|
||||
module Handler.Exam.AddUser
|
||||
( getEAddUserR, postEAddUserR
|
||||
) where
|
||||
|
||||
import Import hiding (Option(..))
|
||||
import Handler.Exam.RegistrationInvite
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Semigroup (Option(..))
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Generics.Deriving.Monoid
|
||||
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurNoCourseRegistration
|
||||
, aurSuccess :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
|
||||
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEAddUserR = postEAddUserR
|
||||
postEAddUserR tid ssh csh examn = do
|
||||
eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
now <- liftIO getCurrentTime
|
||||
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
|
||||
|
||||
let
|
||||
localNow = utcToLocalTime now
|
||||
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays 2 $ utctDay now) 0
|
||||
earliestDate = getOption . fmap getMin $ mconcat
|
||||
[ Option $ Min <$> examStart
|
||||
, foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences
|
||||
]
|
||||
modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate')
|
||||
-> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0
|
||||
defDeadline
|
||||
| Just registerTo <- examRegisterTo
|
||||
, registerTo > now
|
||||
= registerTo
|
||||
| Just earliestDate' <- modifiedEarliestDate
|
||||
= max tomorrowEndOfDay earliestDate'
|
||||
| otherwise
|
||||
= tomorrowEndOfDay
|
||||
|
||||
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
|
||||
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False)
|
||||
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
|
||||
occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
|
||||
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
(fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users
|
||||
|
||||
formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR
|
||||
}
|
||||
where
|
||||
processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
|
||||
processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids
|
||||
|
||||
when (not $ null emails) $
|
||||
tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails
|
||||
|
||||
when (not $ null alreadyRegistered) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField
|
||||
|
||||
when (not $ null registeredNoField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null noCourseRegistration) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
|
||||
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null registeredOneField) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField
|
||||
|
||||
registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
examRegister :: YesodJobDB UniWorX ()
|
||||
examRegister = do
|
||||
insert_ $ ExamRegistration eid uid occId now
|
||||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
|
||||
lift $ lift examRegister
|
||||
throwError $ mempty { aurSuccess = pure userEmail }
|
||||
|
||||
unless registerCourse $
|
||||
throwError $ mempty { aurNoCourseRegistration = pure userEmail }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
|
||||
lift . lift . insert_ $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, ..
|
||||
}
|
||||
lift $ lift examRegister
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
|
||||
|
||||
80
src/Handler/Exam/CorrectorInvite.hs
Normal file
80
src/Handler/Exam/CorrectorInvite.hs
Normal file
@ -0,0 +1,80 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Exam.CorrectorInvite
|
||||
( InvitableJunction(..)
|
||||
, InvitationDBData(..)
|
||||
, InvitationTokenData(..)
|
||||
, examCorrectorInvitationConfig
|
||||
, getECInviteR, postECInviteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Exam
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamCorrector where
|
||||
type InvitationFor ExamCorrector = Exam
|
||||
data InvitableJunction ExamCorrector = JunctionExamCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData ExamCorrector = InvDBDataExamCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector))
|
||||
(\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..})
|
||||
|
||||
instance ToJSON (InvitableJunction ExamCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction ExamCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData ExamCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData ExamCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData ExamCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData ExamCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
examCorrectorInvitationConfig :: InvitationConfig ExamCorrector
|
||||
examCorrectorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
|
||||
fetchExamId tid csh ssh examn
|
||||
invitationSubject (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
|
||||
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
||||
invitationUltDest (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
|
||||
getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getECInviteR = postECInviteR
|
||||
postECInviteR = invitationR examCorrectorInvitationConfig
|
||||
133
src/Handler/Exam/Edit.hs
Normal file
133
src/Handler/Exam/Edit.hs
Normal file
@ -0,0 +1,133 @@
|
||||
module Handler.Exam.Edit
|
||||
( getEEditR, postEEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Exam.Form
|
||||
import Handler.Exam.CorrectorInvite
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEEditR = postEEditR
|
||||
postEEditR tid ssh csh examn = do
|
||||
(cid, eId, template) <- runDB $ do
|
||||
(cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
|
||||
|
||||
template <- examFormTemplate exam
|
||||
|
||||
return (cid, eId, template)
|
||||
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
|
||||
|
||||
formResult editExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
insertRes <- myReplaceUnique eId Exam
|
||||
{ examCourse = cid
|
||||
, examName = efName
|
||||
, examGradingRule = efGradingRule
|
||||
, examBonusRule = efBonusRule
|
||||
, examOccurrenceRule = efOccurrenceRule
|
||||
, examVisibleFrom = efVisibleFrom
|
||||
, examRegisterFrom = efRegisterFrom
|
||||
, examRegisterTo = efRegisterTo
|
||||
, examDeregisterUntil = efDeregisterUntil
|
||||
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
|
||||
, examStart = efStart
|
||||
, examEnd = efEnd
|
||||
, examFinished = efFinished
|
||||
, examClosed = efClosed
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examShowGrades = efShowGrades
|
||||
, examDescription = efDescription
|
||||
}
|
||||
|
||||
when (is _Nothing insertRes) $ do
|
||||
occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
|
||||
deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
|
||||
forM_ (Set.toList efOccurrences) $ \case
|
||||
ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
|
||||
ExamOccurrence
|
||||
{ examOccurrenceExam = eId
|
||||
, examOccurrenceName = eofName
|
||||
, examOccurrenceRoom = eofRoom
|
||||
, examOccurrenceCapacity = eofCapacity
|
||||
, examOccurrenceStart = eofStart
|
||||
, examOccurrenceEnd = eofEnd
|
||||
, examOccurrenceDescription = eofDescription
|
||||
}
|
||||
ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
|
||||
cID <- hoistMaybe eofId
|
||||
eofId' <- decrypt cID
|
||||
oldOcc <- MaybeT $ get eofId'
|
||||
guard $ examOccurrenceExam oldOcc == eId
|
||||
lift $ replace eofId' ExamOccurrence
|
||||
{ examOccurrenceExam = eId
|
||||
, examOccurrenceName = eofName
|
||||
, examOccurrenceRoom = eofRoom
|
||||
, examOccurrenceCapacity = eofCapacity
|
||||
, examOccurrenceStart = eofStart
|
||||
, examOccurrenceEnd = eofEnd
|
||||
, examOccurrenceDescription = eofDescription
|
||||
}
|
||||
|
||||
|
||||
pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
|
||||
deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
|
||||
forM_ (Set.toList efExamParts) $ \case
|
||||
ExamPartForm{ epfId = Nothing, .. } -> insert_
|
||||
ExamPart
|
||||
{ examPartExam = eId
|
||||
, examPartName = epfName
|
||||
, examPartMaxPoints = epfMaxPoints
|
||||
, examPartWeight = epfWeight
|
||||
}
|
||||
ExamPartForm{ .. } -> void . runMaybeT $ do
|
||||
cID <- hoistMaybe epfId
|
||||
epfId' <- decrypt cID
|
||||
oldPart <- MaybeT $ get epfId'
|
||||
guard $ examPartExam oldPart == eId
|
||||
lift $ replace epfId' ExamPart
|
||||
{ examPartExam = eId
|
||||
, examPartName = epfName
|
||||
, examPartMaxPoints = epfMaxPoints
|
||||
, examPartWeight = epfWeight
|
||||
}
|
||||
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
|
||||
|
||||
deleteWhere [ ExamCorrectorExam ==. eId ]
|
||||
insertMany_ $ map (ExamCorrector eId) adds
|
||||
|
||||
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
|
||||
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
||||
|
||||
return insertRes
|
||||
|
||||
case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Nothing -> do
|
||||
addMessageI Success $ MsgExamEdited efName
|
||||
redirect $ CExamR tid ssh csh efName EShowR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
editExamForm = wrapForm editExamWidget def
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
|
||||
, formEncoding = editExamEnctype
|
||||
}
|
||||
$(widgetFile "exam-edit")
|
||||
361
src/Handler/Exam/Form.hs
Normal file
361
src/Handler/Exam/Form.hs
Normal file
@ -0,0 +1,361 @@
|
||||
module Handler.Exam.Form
|
||||
( ExamForm(..)
|
||||
, ExamOccurrenceForm(..)
|
||||
, ExamPartForm(..)
|
||||
, examForm
|
||||
, examFormTemplate, examTemplate
|
||||
, validateExam
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens hiding (parts)
|
||||
|
||||
import Handler.Exam.CorrectorInvite
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
|
||||
|
||||
data ExamForm = ExamForm
|
||||
{ efName :: ExamName
|
||||
, efDescription :: Maybe Html
|
||||
, efStart :: Maybe UTCTime
|
||||
, efEnd :: Maybe UTCTime
|
||||
, efVisibleFrom :: Maybe UTCTime
|
||||
, efRegisterFrom :: Maybe UTCTime
|
||||
, efRegisterTo :: Maybe UTCTime
|
||||
, efDeregisterUntil :: Maybe UTCTime
|
||||
, efPublishOccurrenceAssignments :: Maybe UTCTime
|
||||
, efFinished :: Maybe UTCTime
|
||||
, efClosed :: Maybe UTCTime
|
||||
, efOccurrences :: Set ExamOccurrenceForm
|
||||
, efShowGrades :: Bool
|
||||
, efPublicStatistics :: Bool
|
||||
, efGradingRule :: ExamGradingRule
|
||||
, efBonusRule :: ExamBonusRule
|
||||
, efOccurrenceRule :: ExamOccurrenceRule
|
||||
, efCorrectors :: Set (Either UserEmail UserId)
|
||||
, efExamParts :: Set ExamPartForm
|
||||
}
|
||||
|
||||
data ExamOccurrenceForm = ExamOccurrenceForm
|
||||
{ eofId :: Maybe CryptoUUIDExamOccurrence
|
||||
, eofName :: ExamOccurrenceName
|
||||
, eofRoom :: Text
|
||||
, eofCapacity :: Natural
|
||||
, eofStart :: UTCTime
|
||||
, eofEnd :: Maybe UTCTime
|
||||
, eofDescription :: Maybe Html
|
||||
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
|
||||
|
||||
data ExamPartForm = ExamPartForm
|
||||
{ epfId :: Maybe CryptoUUIDExamPart
|
||||
, epfName :: ExamPartName
|
||||
, epfMaxPoints :: Maybe Points
|
||||
, epfWeight :: Rational
|
||||
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
|
||||
|
||||
makeLenses_ ''ExamForm
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''ExamPartForm
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''ExamOccurrenceForm
|
||||
|
||||
|
||||
examForm :: Maybe ExamForm -> Form ExamForm
|
||||
examForm template html = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
flip (renderAForm FormStandard) html $ ExamForm
|
||||
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
|
||||
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
|
||||
<* aformSection MsgExamFormTimes
|
||||
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (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 MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
|
||||
<* aformSection MsgExamFormOccurrences
|
||||
<*> examOccurrenceForm (efOccurrences <$> template)
|
||||
<* aformSection MsgExamFormAutomaticFunctions
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
|
||||
<*> examGradingRuleForm (efGradingRule <$> template)
|
||||
<*> examBonusRuleForm (efBonusRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
<*> examPartsForm (efExamParts <$> template)
|
||||
|
||||
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
|
||||
examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
Just currentRoute <- getCurrentRoute
|
||||
uid <- liftHandlerT 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 (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
= 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) =
|
||||
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
|
||||
miCell' (Right userId) = do
|
||||
User{..} <- liftHandlerT . 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 MsgMassInputTip) False (Set.toList <$> mPrev)
|
||||
|
||||
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
|
||||
examOccurrenceForm prev = wFormToAForm $ do
|
||||
Just currentRoute <- 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 & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
|
||||
where
|
||||
examOccurrenceForm' nudge mPrev csrf = do
|
||||
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
|
||||
(eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
|
||||
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
|
||||
(eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
|
||||
(eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
|
||||
(eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
|
||||
(eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
|
||||
|
||||
return ( ExamOccurrenceForm
|
||||
<$> eofIdRes
|
||||
<*> eofNameRes
|
||||
<*> eofRoomRes
|
||||
<*> eofCapacityRes
|
||||
<*> eofStartRes
|
||||
<*> eofEndRes
|
||||
<*> (assertM (not . null . renderHtml) <$> eofDescRes)
|
||||
, $(widgetFile "widgets/massinput/examRooms/form")
|
||||
)
|
||||
|
||||
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"
|
||||
|
||||
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
|
||||
examPartsForm prev = wFormToAForm $ do
|
||||
Just currentRoute <- 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 & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
|
||||
where
|
||||
examPartForm' nudge mPrev csrf = do
|
||||
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
|
||||
(epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev)
|
||||
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
|
||||
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
|
||||
|
||||
return ( ExamPartForm
|
||||
<$> epfIdRes
|
||||
<*> 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 (((==) `on` epfName) newDat) 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 :: Entity Exam -> DB ExamForm
|
||||
examFormTemplate (Entity eId Exam{..}) = do
|
||||
parts <- selectList [ ExamPartExam ==. eId ] []
|
||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
||||
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
|
||||
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
|
||||
|
||||
parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
||||
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
|
||||
|
||||
return ExamForm
|
||||
{ efName = examName
|
||||
, efGradingRule = examGradingRule
|
||||
, efBonusRule = examBonusRule
|
||||
, efOccurrenceRule = examOccurrenceRule
|
||||
, efVisibleFrom = examVisibleFrom
|
||||
, efRegisterFrom = examRegisterFrom
|
||||
, efRegisterTo = examRegisterTo
|
||||
, efDeregisterUntil = examDeregisterUntil
|
||||
, efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
|
||||
, efStart = examStart
|
||||
, efEnd = examEnd
|
||||
, efFinished = examFinished
|
||||
, efClosed = examClosed
|
||||
, efShowGrades = examShowGrades
|
||||
, efPublicStatistics = examPublicStatistics
|
||||
, efDescription = examDescription
|
||||
, efOccurrences = Set.fromList $ do
|
||||
(Just -> eofId, ExamOccurrence{..}) <- occurrences'
|
||||
return ExamOccurrenceForm
|
||||
{ eofId
|
||||
, eofName = examOccurrenceName
|
||||
, eofRoom = examOccurrenceRoom
|
||||
, eofCapacity = examOccurrenceCapacity
|
||||
, eofStart = examOccurrenceStart
|
||||
, eofEnd = examOccurrenceEnd
|
||||
, eofDescription = examOccurrenceDescription
|
||||
}
|
||||
, efExamParts = Set.fromList $ do
|
||||
(Just -> epfId, ExamPart{..}) <- parts'
|
||||
return ExamPartForm
|
||||
{ epfId
|
||||
, epfName = examPartName
|
||||
, epfMaxPoints = examPartMaxPoints
|
||||
, epfWeight = examPartWeight
|
||||
}
|
||||
, efCorrectors = Set.unions
|
||||
[ Set.fromList $ map Left invitations
|
||||
, Set.fromList . map Right $ do
|
||||
Entity _ ExamCorrector{..} <- correctors
|
||||
return examCorrectorUser
|
||||
]
|
||||
}
|
||||
|
||||
examTemplate :: CourseId -> DB (Maybe ExamForm)
|
||||
examTemplate cid = runMaybeT $ do
|
||||
newCourse <- MaybeT $ get cid
|
||||
|
||||
[(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
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)
|
||||
|
||||
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
|
||||
, efStart = dateOffset <$> examStart oldExam
|
||||
, efEnd = dateOffset <$> examEnd oldExam
|
||||
, efFinished = dateOffset <$> examFinished oldExam
|
||||
, efClosed = dateOffset <$> examClosed oldExam
|
||||
, efShowGrades = examShowGrades oldExam
|
||||
, efPublicStatistics = examPublicStatistics oldExam
|
||||
, efDescription = examDescription oldExam
|
||||
, efOccurrences = Set.empty
|
||||
, efExamParts = Set.empty
|
||||
, efCorrectors = Set.empty
|
||||
}
|
||||
|
||||
|
||||
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
|
||||
validateExam = do
|
||||
ExamForm{..} <- State.get
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
|
||||
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
|
||||
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart
|
||||
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
|
||||
guardValidation (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)
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
|
||||
[ (/=) `on` eofRoom
|
||||
, (/=) `on` eofStart
|
||||
, (/=) `on` eofEnd
|
||||
, (/=) `on` fmap renderHtml . eofDescription
|
||||
]
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
|
||||
60
src/Handler/Exam/List.hs
Normal file
60
src/Handler/Exam/List.hs
Normal file
@ -0,0 +1,60 @@
|
||||
module Handler.Exam.List
|
||||
( getCExamListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamListR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
now <- liftIO getCurrentTime
|
||||
mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
|
||||
|
||||
let
|
||||
examDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery exam = do
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
return exam
|
||||
dbtRowKey = (E.^. ExamId)
|
||||
dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
|
||||
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
||||
return x
|
||||
dbtColonnade = dbColonnade . mconcat $ catMaybes
|
||||
[ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
||||
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
|
||||
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||||
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
||||
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
|
||||
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
|
||||
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
|
||||
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exams"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
examDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
|
||||
$(widgetFile "exam-list")
|
||||
93
src/Handler/Exam/New.hs
Normal file
93
src/Handler/Exam/New.hs
Normal file
@ -0,0 +1,93 @@
|
||||
module Handler.Exam.New
|
||||
( getCExamNewR, postCExamNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Exam.Form
|
||||
import Handler.Exam.CorrectorInvite
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamNewR = postCExamNewR
|
||||
postCExamNewR tid ssh csh = do
|
||||
(cid, template) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
template <- examTemplate cid
|
||||
return (cid, template)
|
||||
|
||||
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
|
||||
|
||||
formResult newExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
insertRes <- insertUnique Exam
|
||||
{ examName = efName
|
||||
, examCourse = cid
|
||||
, examGradingRule = efGradingRule
|
||||
, examBonusRule = efBonusRule
|
||||
, examOccurrenceRule = efOccurrenceRule
|
||||
, examVisibleFrom = efVisibleFrom
|
||||
, examRegisterFrom = efRegisterFrom
|
||||
, examRegisterTo = efRegisterTo
|
||||
, examDeregisterUntil = efDeregisterUntil
|
||||
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
|
||||
, examStart = efStart
|
||||
, examEnd = efEnd
|
||||
, examFinished = efFinished
|
||||
, examClosed = efClosed
|
||||
, examShowGrades = efShowGrades
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examDescription = efDescription
|
||||
}
|
||||
whenIsJust insertRes $ \examid -> do
|
||||
insertMany_
|
||||
[ ExamPart{..}
|
||||
| ExamPartForm{..} <- Set.toList efExamParts
|
||||
, let examPartExam = examid
|
||||
examPartName = epfName
|
||||
examPartMaxPoints = epfMaxPoints
|
||||
examPartWeight = epfWeight
|
||||
]
|
||||
|
||||
insertMany_
|
||||
[ ExamOccurrence{..}
|
||||
| ExamOccurrenceForm{..} <- Set.toList efOccurrences
|
||||
, let examOccurrenceExam = examid
|
||||
examOccurrenceName = eofName
|
||||
examOccurrenceRoom = eofRoom
|
||||
examOccurrenceCapacity = eofCapacity
|
||||
examOccurrenceStart = eofStart
|
||||
examOccurrenceEnd = eofEnd
|
||||
examOccurrenceDescription = eofDescription
|
||||
]
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
|
||||
insertMany_ [ ExamCorrector{..}
|
||||
| examCorrectorUser <- adds
|
||||
, let examCorrectorExam = examid
|
||||
]
|
||||
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Just _ -> do
|
||||
addMessageI Success $ MsgExamCreated efName
|
||||
redirect $ CourseR tid ssh csh CExamListR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgExamNew
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
newExamForm = wrapForm newExamWidget def
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR
|
||||
, formEncoding = newExamEnctype
|
||||
}
|
||||
$(widgetFile "exam-new")
|
||||
59
src/Handler/Exam/Register.hs
Normal file
59
src/Handler/Exam/Register.hs
Normal file
@ -0,0 +1,59 @@
|
||||
module Handler.Exam.Register
|
||||
( ButtonExamRegister(..)
|
||||
, postERegisterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
|
||||
|
||||
-- Dedicated ExamRegistrationButton
|
||||
data ButtonExamRegister = BtnExamRegister | BtnExamDeregister
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonExamRegister
|
||||
instance Finite ButtonExamRegister
|
||||
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ButtonExamRegister id
|
||||
instance Button UniWorX ButtonExamRegister where
|
||||
btnClasses BtnExamRegister = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnExamDeregister = [BCIsButton, BCDanger]
|
||||
|
||||
btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|]
|
||||
btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|]
|
||||
|
||||
|
||||
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
|
||||
postERegisterR tid ssh csh examn = do
|
||||
Entity uid User{..} <- requireAuth
|
||||
|
||||
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
|
||||
|
||||
((btnResult, _), _) <- runFormPost buttonForm
|
||||
|
||||
formResult btnResult $ \case
|
||||
BtnExamRegister -> do
|
||||
runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ ExamRegistration eId uid Nothing now
|
||||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
addMessageWidget Success [whamlet|
|
||||
<div>#{iconExamRegister True}
|
||||
<div>
|
||||
<div>_{MsgExamRegisteredSuccess examn}
|
||||
|]
|
||||
redirect $ CExamR tid ssh csh examn EShowR
|
||||
BtnExamDeregister -> do
|
||||
runDB $ do
|
||||
deleteBy $ UniqueExamRegistration eId uid
|
||||
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
addMessageWidget Info [whamlet|
|
||||
<div>#{iconExamRegister False}
|
||||
<div>
|
||||
<div>_{MsgExamDeregisteredSuccess examn}
|
||||
|] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
|
||||
redirect $ CExamR tid ssh csh examn EShowR
|
||||
|
||||
invalidArgs ["Register/Deregister button required"]
|
||||
112
src/Handler/Exam/RegistrationInvite.hs
Normal file
112
src/Handler/Exam/RegistrationInvite.hs
Normal file
@ -0,0 +1,112 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Exam.RegistrationInvite
|
||||
( InvitableJunction(..)
|
||||
, InvitationDBData(..)
|
||||
, InvitationTokenData(..)
|
||||
, examRegistrationInvitationConfig
|
||||
, getEInviteR, postEInviteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamRegistration where
|
||||
type InvitationFor ExamRegistration = Exam
|
||||
data InvitableJunction ExamRegistration = JunctionExamRegistration
|
||||
{ jExamRegistrationOccurrence :: Maybe ExamOccurrenceId
|
||||
, jExamRegistrationTime :: UTCTime
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData ExamRegistration = InvDBDataExamRegistration
|
||||
{ invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId
|
||||
, invDBExamRegistrationDeadline :: UTCTime
|
||||
, invDBExamRegistrationCourseRegister :: Bool
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime))
|
||||
(\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..})
|
||||
|
||||
instance ToJSON (InvitableJunction ExamRegistration) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction ExamRegistration) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData ExamRegistration) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData ExamRegistration) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData ExamRegistration) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData ExamRegistration) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
examRegistrationInvitationConfig :: InvitationConfig ExamRegistration
|
||||
examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
|
||||
fetchExamId tid csh ssh examn
|
||||
invitationSubject (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
|
||||
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
|
||||
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
|
||||
itAddAuth
|
||||
| not invDBExamRegistrationCourseRegister
|
||||
= Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered
|
||||
| otherwise
|
||||
= Nothing
|
||||
itStartsAt = Nothing
|
||||
return $ InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
|
||||
isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
case (isRegistered, invDBExamRegistrationCourseRegister) of
|
||||
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant
|
||||
(False, True ) -> do
|
||||
fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $
|
||||
insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime
|
||||
|
||||
Course{..} <- get404 examCourse
|
||||
User{..} <- get404 examRegistrationUser
|
||||
let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent
|
||||
act <* doAudit
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
|
||||
invitationUltDest (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
|
||||
|
||||
getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEInviteR = postEInviteR
|
||||
postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig
|
||||
106
src/Handler/Exam/Show.hs
Normal file
106
src/Handler/Exam/Show.hs
Normal file
@ -0,0 +1,106 @@
|
||||
module Handler.Exam.Show
|
||||
( getEShowR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Exam.Register
|
||||
|
||||
import Utils.Lens hiding (parts)
|
||||
|
||||
import Data.Map ((!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
|
||||
|
||||
getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEShowR tid ssh csh examn = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
mUid <- maybeAuthId
|
||||
|
||||
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
|
||||
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
||||
|
||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||
|
||||
let gradingVisible = NTop (Just cTime) >= NTop examFinished
|
||||
gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
||||
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
||||
|
||||
resultsRaw <- for mUid $ \uid ->
|
||||
E.select . E.from $ \examPartResult -> do
|
||||
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
|
||||
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
|
||||
return examPartResult
|
||||
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
|
||||
|
||||
result <- fmap join . for mUid $ getBy . UniqueExamResult eId
|
||||
|
||||
occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
|
||||
E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
|
||||
let
|
||||
registered
|
||||
| Just uid <- mUid
|
||||
= E.exists . E.from $ \examRegistration -> do
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
|
||||
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
|
||||
| otherwise = E.false
|
||||
E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
|
||||
return (examOccurrence, registered)
|
||||
|
||||
let occurrences = map (over _2 E.unValue) occurrencesRaw
|
||||
|
||||
registered <- for mUid $ existsBy . UniqueExamRegistration eId
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
||||
|
||||
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
|
||||
|
||||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||||
registerWidget
|
||||
| Just isRegistered <- registered
|
||||
, mayRegister = Just $ do
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
[whamlet|
|
||||
<p>
|
||||
$if isRegistered
|
||||
_{MsgExamRegistered}
|
||||
$else
|
||||
_{MsgExamNotRegistered}
|
||||
|]
|
||||
wrapForm examRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
||||
, formEncoding = examRegisterEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
|
||||
| otherwise = Nothing
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original examName
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
gradingKeyW :: [Points] -> Widget
|
||||
gradingKeyW bounds
|
||||
= let boundWidgets :: [Widget]
|
||||
boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds
|
||||
grades :: [ExamGrade]
|
||||
grades = universeF
|
||||
in $(widgetFile "widgets/gradingKey")
|
||||
|
||||
examBonusW :: ExamBonusRule -> Widget
|
||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||
$(widgetFile "exam-show")
|
||||
531
src/Handler/Exam/Users.hs
Normal file
531
src/Handler/Exam/Users.hs
Normal file
@ -0,0 +1,531 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Exam.Users
|
||||
( getEUsersR, postEUsersR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Csv
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Numeric.Lens (integral)
|
||||
import Control.Arrow (Kleisli(..))
|
||||
|
||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
|
||||
|
||||
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))))
|
||||
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms))
|
||||
|
||||
instance HasEntity ExamUserTableData User where
|
||||
hasEntity = _dbrOutput . _2
|
||||
|
||||
instance HasUser ExamUserTableData where
|
||||
hasUser = _dbrOutput . _2 . _entityVal
|
||||
|
||||
_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
|
||||
_userTableOccurrence = _dbrOutput . _3
|
||||
|
||||
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
|
||||
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
|
||||
queryExamOccurrence = $(sqlLOJproj 3 2)
|
||||
|
||||
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
|
||||
resultExamRegistration = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' ExamUserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
|
||||
resultStudyField = _dbrOutput . _6 . _Just
|
||||
|
||||
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
||||
resultExamOccurrence = _dbrOutput . _3 . _Just
|
||||
|
||||
data ExamUserTableCsv = ExamUserTableCsv
|
||||
{ csvEUserSurname :: Maybe Text
|
||||
, csvEUserName :: Maybe Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserField :: Maybe Text
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
, csvEUserOccurrence :: Maybe (CI Text)
|
||||
, csvEUserExercisePoints :: Maybe Points
|
||||
, csvEUserExercisePasses :: Maybe Int
|
||||
, csvEUserExercisePointsMax :: Maybe Points
|
||||
, csvEUserExercisePassesMax :: Maybe Int
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
examUserTableCsvOptions :: Csv.Options
|
||||
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToNamedRecord ExamUserTableCsv where
|
||||
toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
|
||||
|
||||
instance FromNamedRecord ExamUserTableCsv where
|
||||
parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions
|
||||
|
||||
instance DefaultOrdered ExamUserTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
||||
|
||||
instance CsvColumnsExplained ExamUserTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
|
||||
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
|
||||
, ('csvEUserName , MsgCsvColumnExamUserName )
|
||||
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
||||
, ('csvEUserField , MsgCsvColumnExamUserField )
|
||||
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
|
||||
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
|
||||
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
|
||||
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
|
||||
, ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses )
|
||||
, ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
|
||||
, ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax )
|
||||
]
|
||||
|
||||
data ExamUserAction = ExamUserDeregister
|
||||
| ExamUserAssignOccurrence
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe ExamUserAction
|
||||
instance Finite ExamUserAction
|
||||
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''ExamUserAction id
|
||||
|
||||
data ExamUserActionData = ExamUserDeregisterData
|
||||
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
|
||||
|
||||
data ExamUserCsvActionClass
|
||||
= ExamUserCsvCourseRegister
|
||||
| ExamUserCsvRegister
|
||||
| ExamUserCsvAssignOccurrence
|
||||
| ExamUserCsvSetCourseField
|
||||
| ExamUserCsvDeregister
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
|
||||
|
||||
data ExamUserCsvAction
|
||||
= ExamUserCsvCourseRegisterData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvRegisterData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvAssignOccurrenceData
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvSetCourseFieldData
|
||||
{ examUserCsvActCourseParticipant :: CourseParticipantId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
}
|
||||
| ExamUserCsvDeregisterData
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
|
||||
, fieldLabelModifier = camelToPathPiece' 3
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''ExamUserCsvAction
|
||||
|
||||
data ExamUserCsvException
|
||||
= ExamUserCsvExceptionNoMatchingUser
|
||||
| ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
| ExamUserCsvExceptionNoMatchingOccurrence
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception ExamUserCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
||||
|
||||
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEUsersR = postEUsersR
|
||||
postEUsersR tid ssh csh examn = do
|
||||
(registrationResult, examUsersTable) <- runDB $ do
|
||||
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
|
||||
bonus <- examBonus exam
|
||||
|
||||
let
|
||||
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
|
||||
showPasses = numSheetsPasses allBoni /= 0
|
||||
showPoints = getSum (numSheetsPoints allBoni) /= 0
|
||||
|
||||
let
|
||||
examUsersDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
|
||||
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
|
||||
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
|
||||
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
|
||||
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
|
||||
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
|
||||
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
|
||||
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
|
||||
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
||||
dbtProj = return
|
||||
dbtColonnade = mconcat $ catMaybes
|
||||
[ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
|
||||
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
, pure colUserMatriclenr
|
||||
, pure $ colField resultStudyField
|
||||
, pure $ colDegreeShort resultStudyDegree
|
||||
, pure $ colFeaturesSemester resultStudyFeatures
|
||||
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
|
||||
SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
|
||||
SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
|
||||
return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
|
||||
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
|
||||
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
|
||||
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
|
||||
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser
|
||||
, sortUserSurname queryUser
|
||||
, sortUserDisplayName queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, sortField queryStudyField
|
||||
, sortDegreeShort queryStudyDegree
|
||||
, sortFeaturesSemester queryStudyFeatures
|
||||
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
, fltrUserMatriclenr queryUser
|
||||
, fltrField queryStudyField
|
||||
, fltrDegree queryStudyDegree
|
||||
, fltrFeaturesSemester queryStudyFeatures
|
||||
, ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
, fltrFieldUI mPrev
|
||||
, fltrDegreeUI mPrev
|
||||
, fltrFeaturesSemesterUI mPrev
|
||||
, prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional = \csrf -> do
|
||||
let
|
||||
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
|
||||
actionMap = Map.fromList
|
||||
[ ( ExamUserDeregister
|
||||
, pure ExamUserDeregisterData
|
||||
)
|
||||
, ( ExamUserAssignOccurrence
|
||||
, ExamUserAssignOccurrenceData
|
||||
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
|
||||
)
|
||||
]
|
||||
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
||||
let formRes = (, mempty) . First . Just <$> res
|
||||
return (formRes, formWgt)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exam-users"
|
||||
dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
|
||||
dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
|
||||
<$> view (resultUser . _entityVal . _userSurname . to Just)
|
||||
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userMatrikelnummer)
|
||||
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
|
||||
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
uid <- lift $ view _2 <$> guessUser csv
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
|
||||
, dbtCsvComputeActions = \case
|
||||
DBCsvDiffMissing{dbCsvOldKey}
|
||||
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
||||
DBCsvDiffNew{dbCsvNewKey = Just _}
|
||||
-> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
(isPart, uid) <- lift $ guessUser dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
| otherwise ->
|
||||
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
|
||||
DBCsvDiffExisting{..} -> do
|
||||
newOccurrence <- lift $ lookupOccurrence dbCsvNew
|
||||
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
|
||||
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
|
||||
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
, dbtCsvClassifyAction = \case
|
||||
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
|
||||
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
|
||||
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
|
||||
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
||||
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
ExamUserCsvCourseRegister -> DBCsvActionNew
|
||||
ExamUserCsvRegister -> DBCsvActionNew
|
||||
ExamUserCsvDeregister -> DBCsvActionMissing
|
||||
_other -> DBCsvActionExisting
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \case
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ CourseParticipant
|
||||
{ courseParticipantCourse = examCourse
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
}
|
||||
User{userIdent} <- getJust examUserCsvActUser
|
||||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
, examRegistrationUser = examUserCsvActUser
|
||||
, examRegistrationOccurrence = examUserCsvActOccurrence
|
||||
, examRegistrationTime = now
|
||||
}
|
||||
ExamUserCsvRegisterData{..} -> do
|
||||
examRegistrationTime <- liftIO getCurrentTime
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
, examRegistrationUser = examUserCsvActUser
|
||||
, examRegistrationOccurrence = examUserCsvActOccurrence
|
||||
, ..
|
||||
}
|
||||
ExamUserCsvAssignOccurrenceData{..} ->
|
||||
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
|
||||
ExamUserCsvSetCourseFieldData{..} ->
|
||||
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
||||
ExamUserCsvDeregisterData{..} -> do
|
||||
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
|
||||
User{userIdent} <- getJust examRegistrationUser
|
||||
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
delete examUserCsvActRegistration
|
||||
return $ CExamR tid ssh csh examn EUsersR
|
||||
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvAssignOccurrenceData{..} -> do
|
||||
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{registeredUserName' examUserCsvActRegistration}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
|]
|
||||
ExamUserCsvDeregisterData{..}
|
||||
-> registeredUserName' examUserCsvActRegistration
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
||||
}
|
||||
where
|
||||
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
||||
studyFeaturesWidget featId = do
|
||||
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
||||
|]
|
||||
|
||||
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
Entity _ User{..} = view resultUser $ existing ! registration
|
||||
|
||||
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
|
||||
users <- E.select . E.from $ \user -> do
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
|
||||
, (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
|
||||
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
|
||||
]
|
||||
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
E.limit 2
|
||||
return $ (isCourseParticipant, user E.^. UserId)
|
||||
case users of
|
||||
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
|
||||
-> return (isPart, uid)
|
||||
[(E.Value isPart, E.Value uid)]
|
||||
-> return (isPart, uid)
|
||||
_other
|
||||
-> throwM ExamUserCsvExceptionNoMatchingUser
|
||||
|
||||
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
|
||||
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
|
||||
occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
|
||||
case occIds of
|
||||
[occId] -> return occId
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
|
||||
|
||||
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
||||
uid <- view _2 <$> guessUser csv
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
|
||||
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ do
|
||||
field <- csvEUserField
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||
]
|
||||
, do
|
||||
degree <- csvEUserDegree
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||
]
|
||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
|
||||
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
||||
E.limit 2
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
_other
|
||||
| is _Nothing csvEUserField
|
||||
, is _Nothing csvEUserDegree
|
||||
, is _Nothing csvEUserSemester
|
||||
-> return Nothing
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
examUsersDBTableValidator = def
|
||||
|
||||
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
|
||||
postprocess inp = do
|
||||
(First (Just act), regMap) <- inp
|
||||
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
|
||||
return (act, regSet)
|
||||
over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
|
||||
|
||||
formResult registrationResult $ \case
|
||||
(ExamUserDeregisterData, selectedRegistrations) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
||||
]
|
||||
addMessageI Success $ MsgExamUsersDeregistered nrDel
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
(ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
|
||||
nrUpdated <- runDB $ updateWhereCount
|
||||
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
||||
]
|
||||
[ ExamRegistrationOccurrence =. occId
|
||||
]
|
||||
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
|
||||
$(widgetFile "exam-users")
|
||||
@ -1000,3 +1000,36 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
[] -> return $ Left email
|
||||
[E.Value uid] -> return $ Right uid
|
||||
_other -> fail "Ambiguous e-mail addr"
|
||||
|
||||
examResultField :: forall m res.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, PathPiece res
|
||||
)
|
||||
=> Field m res -> Field m (ExamResult' res)
|
||||
examResultField innerField = Field
|
||||
{ fieldEnctype = UrlEncoded <> fieldEnctype innerField
|
||||
, fieldParse = \ts fs -> if
|
||||
| [t] <- ts
|
||||
, Just res <- fromPathPiece t
|
||||
, is _ExamNoShow res || is _ExamVoided res
|
||||
-> return . Right $ Just res
|
||||
| otherwise
|
||||
-> fmap (fmap ExamAttended) <$> fieldParse innerField ts fs
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
innerId <- newIdent
|
||||
let
|
||||
val' :: ExamResult' (Either Text res)
|
||||
val' = either (ExamAttended . Left) (fmap Right) val
|
||||
innerVal :: Either Text res
|
||||
innerVal = val >>= maybe (Left "") return . preview _ExamAttended
|
||||
[whamlet|
|
||||
$newline never
|
||||
<select id=#{theId} name=#{name} *{attrs} :isReq:required>
|
||||
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
|
||||
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
|
||||
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
|
||||
<fieldset uw-interactive-fieldset data-conditional-input=#{theId} data-conditional-value="attended">
|
||||
^{fieldView innerField innerId name attrs innerVal False}
|
||||
|]
|
||||
}
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
{-|
|
||||
Module: Model.Types.Exam
|
||||
@ -13,10 +14,12 @@ import Model.Types.Common
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
data ExamResult' res = ExamAttended { examResult :: res }
|
||||
| ExamNoShow
|
||||
| ExamVoided
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
@ -25,6 +28,52 @@ deriveJSON defaultOptions
|
||||
} ''ExamResult'
|
||||
derivePersistFieldJSON ''ExamResult'
|
||||
|
||||
makePrisms ''ExamResult'
|
||||
|
||||
instance PathPiece res => PathPiece (ExamResult' res) where
|
||||
toPathPiece ExamAttended{..} = toPathPiece examResult
|
||||
toPathPiece ExamNoShow = "no-show"
|
||||
toPathPiece ExamVoided = "voided"
|
||||
|
||||
fromPathPiece t
|
||||
| t == "no-show" = Just ExamNoShow
|
||||
| t == "voided" = Just ExamVoided
|
||||
| Just examResult <- fromPathPiece t
|
||||
= Just ExamAttended{..}
|
||||
| otherwise = Nothing
|
||||
|
||||
instance Applicative ExamResult' where
|
||||
pure = ExamAttended
|
||||
ExamAttended f <*> ExamAttended x = ExamAttended $ f x
|
||||
ExamAttended _ <*> ExamNoShow = ExamNoShow
|
||||
ExamAttended _ <*> ExamVoided = ExamVoided
|
||||
ExamNoShow <*> _ = ExamNoShow
|
||||
ExamVoided <*> _ = ExamVoided
|
||||
|
||||
instance Semigroup res => Semigroup (ExamResult' res) where
|
||||
ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r'
|
||||
ExamVoided <> _ = ExamVoided
|
||||
_ <> ExamVoided = ExamVoided
|
||||
_ <> _ = ExamNoShow
|
||||
|
||||
instance Monoid res => Monoid (ExamResult' res) where
|
||||
mempty = ExamAttended mempty
|
||||
ExamAttended r `mappend` ExamAttended r' = ExamAttended $ r `mappend` r'
|
||||
ExamVoided `mappend` _ = ExamVoided
|
||||
_ `mappend` ExamVoided = ExamVoided
|
||||
_ `mappend` _ = ExamNoShow
|
||||
|
||||
instance Csv.ToField res => Csv.ToField (ExamResult' res) where
|
||||
toField ExamVoided = "voided"
|
||||
toField ExamNoShow = "no-show"
|
||||
toField ExamAttended{..} = Csv.toField examResult
|
||||
|
||||
instance Csv.FromField res => Csv.FromField (ExamResult' res) where
|
||||
parseField "voided" = pure ExamVoided
|
||||
parseField "no-show" = pure ExamNoShow
|
||||
parseField x = ExamAttended <$> Csv.parseField x
|
||||
|
||||
|
||||
data ExamBonusRule = ExamNoBonus
|
||||
| ExamBonusPoints
|
||||
{ bonusMaxPoints :: Points
|
||||
@ -102,9 +151,6 @@ instance PathPiece ExamGrade where
|
||||
pathPieceJSON ''ExamGrade
|
||||
pathPieceJSONKey ''ExamGrade
|
||||
|
||||
passingGrade :: ExamGrade -> Bool
|
||||
passingGrade = (>= Grade40)
|
||||
|
||||
data ExamGradingRule
|
||||
= ExamGradingManual
|
||||
| ExamGradingKey
|
||||
@ -118,5 +164,20 @@ deriveJSON defaultOptions
|
||||
} ''ExamGradingRule
|
||||
derivePersistFieldJSON ''ExamGradingRule
|
||||
|
||||
|
||||
newtype ExamPassed = ExamPassed { examPassed :: Bool }
|
||||
deriving (Read, Show, Generic, Typeable)
|
||||
deriving newtype (Eq, Ord, Enum, Bounded)
|
||||
|
||||
deriveFinite ''ExamPassed
|
||||
finitePathPiece ''ExamPassed ["failed", "passed"]
|
||||
makeWrapped ''ExamPassed
|
||||
|
||||
passingGrade :: Iso' ExamGrade ExamPassed
|
||||
-- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10`
|
||||
passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed)
|
||||
|
||||
|
||||
type ExamResultPoints = ExamResult' (Maybe Points)
|
||||
type ExamResultGrade = ExamResult' ExamGrade
|
||||
type ExamResultPassed = ExamResult' ExamPassed
|
||||
|
||||
@ -12,7 +12,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
|
||||
$if examShowGrades
|
||||
_{grade}
|
||||
$else
|
||||
$if passingGrade grade
|
||||
$if view (passingGrade . _Wrapped) grade
|
||||
_{MsgExamPassed}
|
||||
$else
|
||||
_{MsgExamNotPassed}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user