fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(course and exam registration): distinguish registrations buttons

Browse Source 
registration buttons for course and exam carry different texts and icons

Closes #416
This commit is contained in:
Steffen Jost 2019-07-16 11:17:27 +02:00
parent 643cc4165f
commit ad825b66b8
6 changed files with 114 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/de.msg
View File

@ -5,6 +5,10 @@ BtnAbort: Abbrechen
BtnDelete: Löschen
BtnRegister: Anmelden
BtnDeregister: Abmelden
BtnCourseRegister: Zum Kurs anmelden
BtnCourseDeregister: Vom Kurs abmelden
BtnExamRegister: Klasuranmeldung
BtnExamDeregister: Abmeldung von der Klausur
BtnHijack: Sitzung übernehmen
BtnSave: Speichern
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.

2
src/Database/Esqueleto/Utils.hs
View File

@ -160,7 +160,7 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs
orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByOrd = let sortUni = zipWith (,) [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
\x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)

72
src/Handler/Course.hs
View File

@ -46,6 +46,21 @@ import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@ -330,7 +345,7 @@ getCShowR tid ssh csh = do
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
(regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course
(regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course
let regForm = wrapForm regWidget def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
, formEncoding = regEnctype
@ -426,21 +441,30 @@ getCShowR tid ssh csh = do
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
isRegistered <- case mbAid of
Nothing -> return False
Just uid -> existsBy $ UniqueExamRegistration eId uid
if
| mayRegister -> do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
, formEncoding = examRegisterEnctype
, formSubmit = FormNoSubmit
}
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
| otherwise -> return mempty
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR tid ssh csh examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|]
-- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
-- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
-- isRegistered <- case mbAid of
-- Nothing -> return False
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
-- if
-- | mayRegister -> do
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- return $ wrapForm examRegisterForm def
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-- , formEncoding = examRegisterEnctype
-- , formSubmit = FormNoSubmit
-- }
-- | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
-- | otherwise -> return mempty
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
@ -448,6 +472,14 @@ getCShowR tid ssh csh = do
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
, ("registered", SortColumn $ \exam ->
case mbAid of
Nothing -> E.false
Just uid ->
E.exists $ E.from $ \reg -> do
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
@ -470,9 +502,9 @@ getCShowR tid ssh csh = do
-- , maybe existing features if already registered
-- , maybe some default study features
-- , maybe a course secret
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
courseRegisterForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
courseRegisterForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
-- secret fields
(msecretRes', msecretView) <- case msecret of
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
@ -486,7 +518,7 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist
_other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
-- button de-/register
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
(btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister isRegistered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/register-form/register-form")
let msecretRes | Just res <- msecretRes' = Just <$> res
@ -521,7 +553,7 @@ postCRegisterR tid ssh csh = do
registration <- getBy (UniqueParticipant aid cid)
return (cid, course, entityVal <$> registration)
let isRegistered = isJust registration
((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course
formResult regResult $ \(mbSfId,codeOk) -> if
| isRegistered -> do
runDB $ deleteBy $ UniqueParticipant aid cid
@ -1367,8 +1399,8 @@ postCUserR tid ssh csh uCId = do
redirect $ currentRoute :#: registrationFieldFrag
let regButton
| Just _ <- mRegistration = BtnDeregister
| otherwise = BtnRegister
| Just _ <- mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
let registrationButtonFrag :: Text
@ -1382,7 +1414,7 @@ postCUserR tid ssh csh uCId = do
, formAnchor = Just registrationButtonFrag
}
formResult regButtonRes $ \case
BtnDeregister
BtnCourseDeregister
| Just (Entity pId _) <- mRegistration
-> do
runDB $ delete pId
@ -1390,7 +1422,7 @@ postCUserR tid ssh csh uCId = do
redirect $ CourseR tid ssh csh CUsersR
| otherwise
-> invalidArgs ["User not registered"]
BtnRegister -> do
BtnCourseRegister -> do
now <- liftIO getCurrentTime
let primaryField
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies

61
src/Handler/Exam.hs
View File

@ -35,6 +35,23 @@ import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
-- 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}|]
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
@ -82,7 +99,7 @@ getCExamListR tid ssh csh = do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
$(widgetFile "exam-list")
instance IsInvitableJunction ExamCorrector where
type InvitationFor ExamCorrector = Exam
data InvitableJunction ExamCorrector = JunctionExamCorrector
@ -274,7 +291,7 @@ examOccurrenceForm prev = wFormToAForm $ do
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
@ -294,7 +311,7 @@ examOccurrenceForm prev = wFormToAForm $ do
<*> (assertM (not . null . renderHtml) <$> eofDescRes)
, $(widgetFile "widgets/massinput/examRooms/form")
)
miAdd' nudge submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
@ -314,7 +331,7 @@ examPartsForm prev = wFormToAForm $ do
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
@ -330,7 +347,7 @@ examPartsForm prev = wFormToAForm $ do
<*> epfWeightRes
, $(widgetFile "widgets/massinput/examParts/form")
)
miAdd' nudge submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(res, formWidget) <- examPartForm' nudge Nothing csrf
@ -342,7 +359,7 @@ examPartsForm prev = wFormToAForm $ do
miCell' nudge dat = examPartForm' nudge (Just dat)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
miIdent' :: Text
miIdent' = "exam-parts"
miIdent' = "exam-parts"
examFormTemplate :: Entity Exam -> DB ExamForm
examFormTemplate (Entity eId Exam{..}) = do
@ -400,7 +417,7 @@ examFormTemplate (Entity eId Exam{..}) = do
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)
@ -419,7 +436,7 @@ examTemplate cid = runMaybeT $ do
newTerm <- MaybeT . get $ courseTerm newCourse
let
dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm
dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm
return ExamForm
{ efName = examName oldExam
@ -447,7 +464,7 @@ examTemplate cid = runMaybeT $ do
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
@ -460,7 +477,7 @@ validateExam = do
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd
@ -483,7 +500,7 @@ postCExamNewR tid ssh csh = 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
@ -527,7 +544,7 @@ postCExamNewR tid ssh csh = do
examOccurrenceEnd = eofEnd
examOccurrenceDescription = eofDescription
]
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
insertMany_ [ ExamCorrector{..}
| examCorrectorUser <- adds
@ -665,13 +682,13 @@ postEEditR tid ssh csh examn = do
, 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
@ -718,7 +735,7 @@ getEShowR tid ssh csh examn = do
registerWidget
| Just isRegistered <- registered
, mayRegister = Just $ do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
[whamlet|
<p>
$if isRegistered
@ -768,13 +785,13 @@ 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)
@ -786,7 +803,7 @@ resultStudyFeatures = _dbrOutput . _4 . _Just
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just
@ -820,7 +837,7 @@ getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName ->
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn
let
examUsersDBTable = DBTable{..}
where
@ -844,7 +861,7 @@ postEUsersR tid ssh csh examn = do
, colDegreeShort resultStudyDegree
, colFeaturesSemester resultStudyFeatures
, sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
]
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserSurname queryUser
@ -908,14 +925,14 @@ postERegisterR tid ssh csh examn = do
((btnResult, _), _) <- runFormPost buttonForm
formResult btnResult $ \case
BtnRegister -> do
BtnExamRegister -> 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
BtnExamDeregister -> do
runDB $ do
deleteBy $ UniqueExamRegistration eId uid
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent

2
src/Handler/Home.hs
View File

@ -251,7 +251,7 @@ homeUpcomingExams uid = do
| otherwise -> return mempty
-}
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
let Entity eId Exam{..} = view lensExam dbrOutput
let Entity eId Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
isRegistered <- existsBy $ UniqueExamRegistration eId uid

18
src/Utils.hs
View File

@ -153,6 +153,22 @@ iconProblem = fontAwesomeIcon "bolt"
iconHint :: Markup
iconHint = fontAwesomeIcon "life-ring"
-- Icons for Course
iconCourse :: Markup
iconCourse = fontAwesomeIcon "graduation-cap"
iconExam :: Markup
iconExam = fontAwesomeIcon "file-invoice"
iconEnrol :: Bool -> Markup
iconEnrol True = fontAwesomeIcon "user-plus"
iconEnrol False = fontAwesomeIcon "user-slash"
iconExamRegister :: Bool -> Markup
iconExamRegister True = fontAwesomeIcon "calendar-check"
iconExamRegister False = fontAwesomeIcon "calendar-times"
-- Icons for SheetFileType
iconSolution :: Markup
iconSolution =fontAwesomeIcon "exclamation-circle"
@ -170,7 +186,7 @@ iconCSV :: Markup
iconCSV = fontAwesomeIcon "file-csv"
-- Conditional icons
-- Generic Conditional icons
isVisible :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is visible or invisible