869 lines
40 KiB
Haskell
869 lines
40 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
|
||
module Handler.Exam where
|
||
|
||
import Import
|
||
|
||
import Handler.Utils
|
||
import Handler.Utils.Exam
|
||
import Handler.Utils.Invitations
|
||
import Handler.Utils.Table.Columns
|
||
import Handler.Utils.Table.Cells
|
||
import Jobs.Queue
|
||
|
||
import Utils.Lens hiding (parts)
|
||
|
||
import qualified Database.Esqueleto as E
|
||
import qualified Database.Esqueleto.Utils as E
|
||
import Database.Esqueleto.Utils.TH
|
||
|
||
import Data.Map ((!), (!?))
|
||
import qualified Data.Map as Map
|
||
import qualified Data.Set as Set
|
||
|
||
import Data.Aeson hiding (Result(..))
|
||
import Text.Hamlet (ihamlet)
|
||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
||
|
||
import qualified Data.CaseInsensitive as CI
|
||
|
||
import qualified Control.Monad.State.Class as State
|
||
|
||
|
||
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) $ toWidget 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{..} } -> cell $ do
|
||
startT <- formatTime SelFormatDateTime examStart
|
||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||
[whamlet|
|
||
$newline never
|
||
#{startT}
|
||
$maybe endT' <- endT
|
||
\ – #{endT'}
|
||
|]
|
||
]
|
||
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"
|
||
|
||
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")
|
||
|
||
|
||
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 Exam{..} _ = do
|
||
Course{..} <- get404 examCourse
|
||
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
|
||
invitationHeading 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
|
||
invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
||
invitationUltDest Exam{..} _ = do
|
||
Course{..} <- get404 examCourse
|
||
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR
|
||
|
||
getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||
getECInviteR = postECInviteR
|
||
postECInviteR = invitationR examCorrectorInvitationConfig
|
||
|
||
|
||
data ExamForm = ExamForm
|
||
{ efName :: ExamName
|
||
, efDescription :: Maybe Html
|
||
, efStart :: UTCTime
|
||
, efEnd :: Maybe UTCTime
|
||
, efVisibleFrom :: Maybe UTCTime
|
||
, efRegisterFrom :: Maybe UTCTime
|
||
, efRegisterTo :: Maybe UTCTime
|
||
, efDeregisterUntil :: Maybe UTCTime
|
||
, efPublishOccurrenceAssignments :: 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
|
||
, 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)
|
||
|
||
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
|
||
<*> areq 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)
|
||
<*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (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)
|
||
<*> bonusRuleForm (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) True (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) True $ Set.toList <$> prev
|
||
where
|
||
examOccurrenceForm' nudge mPrev csrf = do
|
||
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
|
||
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (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
|
||
<*> 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) True $ 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
|
||
, 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 $ efStart >= efPublishOccurrenceAssignments
|
||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart)
|
||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart)
|
||
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
|
||
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart)
|
||
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
|
||
|
||
|
||
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
|
||
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")
|
||
|
||
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
|
||
, 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
|
||
, 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")
|
||
|
||
|
||
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)) <- 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 = cTime >= 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
|
||
|
||
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister))
|
||
|
||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||
registerWidget
|
||
| Just isRegistered <- registered
|
||
, mayRegister = Just $ do
|
||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] 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")
|
||
|
||
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)
|
||
|
||
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)
|
||
|
||
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
|
||
|
||
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||
getEUsersR = postEUsersR
|
||
postEUsersR tid ssh csh examn = do
|
||
Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn
|
||
|
||
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 = dbColonnade $ mconcat
|
||
[ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||
, colUserMatriclenr
|
||
, colField resultStudyField
|
||
, colDegreeShort resultStudyDegree
|
||
, colFeaturesSemester resultStudyFeatures
|
||
, sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
|
||
]
|
||
dbtSorting = Map.fromList
|
||
[ sortUserNameLink queryUser
|
||
, sortUserSurname queryUser
|
||
, sortUserDisplayName queryUser
|
||
, sortUserMatriclenr queryUser
|
||
, sortField queryStudyField
|
||
, sortDegreeShort queryStudyDegree
|
||
, sortFeaturesSemester queryStudyFeatures
|
||
]
|
||
dbtFilter = Map.fromList
|
||
[ fltrUserNameEmail queryUser
|
||
, fltrUserMatriclenr queryUser
|
||
, fltrField queryStudyField
|
||
, fltrDegree queryStudyDegree
|
||
, fltrFeaturesSemester queryStudyFeatures
|
||
]
|
||
dbtFilterUI mPrev = mconcat
|
||
[ fltrUserNameEmailUI mPrev
|
||
, fltrUserMatriclenrUI mPrev
|
||
, fltrFieldUI mPrev
|
||
, fltrDegreeUI mPrev
|
||
, fltrFeaturesSemesterUI mPrev
|
||
]
|
||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||
dbtParams = def
|
||
dbtIdent :: Text
|
||
dbtIdent = "exam-users"
|
||
|
||
examUsersDBTableValidator = def
|
||
((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable
|
||
|
||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
|
||
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
|
||
$(widgetFile "exam-users")
|
||
|
||
|
||
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||
getEAddUserR = postEAddUserR
|
||
postEAddUserR = error "postEAddUserR"
|
||
|
||
getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||
getEInviteR = postEInviteR
|
||
postEInviteR = error "postEInviteR"
|
||
|
||
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
|
||
BtnRegister -> do
|
||
runDB $ do
|
||
now <- liftIO getCurrentTime
|
||
insert_ $ ExamRegistration eId uid Nothing now
|
||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||
addMessageI Success $ MsgExamRegisteredSuccess examn
|
||
redirect $ CExamR tid ssh csh examn EShowR
|
||
BtnDeregister -> do
|
||
runDB $ do
|
||
deleteBy $ UniqueExamRegistration eId uid
|
||
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||
addMessageI Success $ MsgExamDeregisteredSuccess examn
|
||
redirect $ CExamR tid ssh csh examn EShowR
|
||
|
||
invalidArgs ["Register/Deregister button required"]
|