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

Registration takes Field of Studies now

Browse Source
This commit is contained in:
SJost 2019-02-28 17:17:34 +01:00
parent 3966ad9b24
commit 933eaa7362
4 changed files with 58 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/de.msg
View File

@ -53,7 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet
CourseStudyFeature: Relevantes Hauptfach
CourseStudyFeature: Asoziiertes Hauptfach
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort
CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.

62
src/Handler/Course.hs
View File

@ -290,48 +290,64 @@ 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 $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
(regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
siteLayout (toWgt $ courseName course) $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")
registerForm :: Bool -> Maybe Text -> Form Bool
-- | Registration button with primary study features if logged in
-- , existing features if already registered
-- , and possibly a course secret
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
registerForm registered msecret extra = do
(msecretRes', msecretView) <- case msecret of
(Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing)
(_msfRes, msfView) <- if not registered then return (Nothing, Nothing) else
bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
registerForm loggedin participant msecret = identForm FIDcourseRegister $ \extra -> do
-- secret fields
(msecretRes', msecretView) <- case msecret of
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing)
-- study features
(msfRes', msfView) <- case loggedin of
Nothing -> return (Nothing,Nothing)
Just _ -> bimap Just Just <$> case participant of
Just CourseParticipant{courseParticipantField=Just sfid}
-> mopt (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just $ Just sfid)
_other -> mopt (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
& setTooltip MsgCourseStudyFeatureTooltip) Nothing
-- button de-/register
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/register-form/register-form")
let msecretRes | Just res <- msecretRes' = Just <$> res
| otherwise = FormSuccess Nothing
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
let widget = $(widgetFile "widgets/register-form/register-form")
let msecretRes | Just res <- msecretRes' = Just <$> res
| otherwise = FormSuccess Nothing
let msfRes | Just res <- msfRes' = res
| otherwise = FormSuccess Nothing
-- checks that correct button was pressed, and ignores result of btnRes
let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
return (formRes, widget)
where
isRegistered = isJust participant
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
aid <- requireAuthId
(cid, course, registered) <- runDB $ do
(cid, course, registration) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> getBy (UniqueParticipant aid cid)
return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
case regResult of
(FormSuccess codeOk)
| registered -> do
registration <- getBy (UniqueParticipant aid cid)
return (cid, course, entityVal <$> registration)
let isRegistered = isJust registration
((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration $ courseRegisterSecret course
formResult regResult $ \(mbSfId,codeOk) -> if
| isRegistered -> do
runDB $ deleteBy $ UniqueParticipant aid cid
addMessageI Info MsgCourseDeregisterOk
| codeOk -> do
actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime Nothing -- TODO
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong
_other -> return () -- TODO check this!
-- addMessage Info $ toHtml $ show regResult -- For debugging only
redirect $ CourseR tid ssh csh CShowR

24
src/Handler/Utils/Form.hs
View File

@ -214,19 +214,25 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
-- | Select one of the user's primary courses
studyFeaturesPrimaryFieldFor :: UserId -> Field Handler StudyFeaturesId
studyFeaturesPrimaryFieldFor uid = selectField $ do
-- we wanted to use optionsPersistCryptoId, but we need a join here
-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler StudyFeaturesId
studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
-- we need a join, so we cannot just use optionsPersistCryptoId
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId
E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
E.where_ $ feature E.^. StudyFeaturesUser E.==. E.val uid
E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True
E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary
E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId
E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
E.||. isPrimaryActiveUserStudyFeature feature
return (feature E.^. StudyFeaturesId, degree, field)
mkOptionList <$> mapM procOptions rawOptions
where
isPrimaryActiveUserStudyFeature feature = case mbuid of
Nothing -> E.val False
(Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid
E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary
procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option StudyFeaturesId)
procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName )

4
test/Database.hs
View File

@ -448,8 +448,8 @@ fillDb = do
, courseRegisterFrom = Nothing
, courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseRegisterSecret = Just "dbs"
, courseMaterialFree = False
}
insert_ $ CourseEdit gkleen now dbs
void . insert' $ DegreeCourse dbs sdBsc sdInf