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

Redesign course-user

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-10 21:32:16 +02:00
parent 9f9312661d
commit bf287a4a99
8 changed files with 173 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
messages/uniworx/de.msg
View File

@ -19,8 +19,7 @@ BtnCorrInvDecline: Ablehnen
Aborted: Abgebrochen
Remarks: Hinweise
Registered: Angemeldet
RegisteredHeader: Anmeldung
RegisteredSince date@Text: Angemeldet seit #{date}
RegisteredSince: Angemeldet seit
RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
@ -74,7 +73,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Anmeldung erfolgreich
CourseDeregisterOk: Erfolgreich abgemeldet
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
CourseStudyFeature: Assoziiertes Hauptfach
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert
CourseTutorial: Tutorium
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
CourseSecretWrong: Falsches Kennwort

118
src/Handler/Course.hs
View File

@ -423,8 +423,8 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist
Nothing -> return (Nothing,Nothing)
Just _ -> bimap Just Just <$> case participant of
Just CourseParticipant{courseParticipantField=Just sfid}
-> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
_other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
-> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
_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
@ -1140,7 +1140,7 @@ postCUsersR tid ssh csh = do
, colUserDegreeShort
, colUserField
, colUserSemester
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
, sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
, colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
@ -1225,11 +1225,11 @@ postCUserR tid ssh csh uCId = do
dozentId <- requireAuthId
uid <- decrypt uCId
-- DB reads
(cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do
(cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- Abfrage Benutzerdaten
user <- get404 uid
registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid)
registration <- getBy (UniqueParticipant uid cid)
-- Abfrage Teilnehmernotiz
let thisUniqueNote = UniqueCourseUserNote uid cid
mbNoteEnt <- getBy thisUniqueNote
@ -1249,8 +1249,7 @@ postCUserR tid ssh csh uCId = do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies)
return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
let editByWgt = [whamlet|
$forall (etime,_eemail,ename,_esurname) <- noteEdits
<br>
@ -1259,36 +1258,93 @@ postCUserR tid ssh csh uCId = do
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
<* saveButton
formResult noteRes $ \mbNote -> (do
let noteFrag :: Text
noteFrag = "notes"
noteWidget = wrapForm noteView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
, formEncoding = noteEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Just noteFrag
}
formResult noteRes $ \mbNote -> do
now <- liftIO getCurrentTime
case mbNote of
runDB $ case mbNote of
Nothing -> do
runDB $ do
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
deleteBy thisUniqueNote
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
deleteBy thisUniqueNote
addMessageI Info MsgCourseUserNoteDeleted
redirect currentRoute -- reload page after post
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
(Just note) -> do
runDB $ do
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
void . insert $ CourseUserNoteEdit dozentId now noteKey
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
void . insert $ CourseUserNoteEdit dozentId now noteKey
addMessageI Success MsgCourseUserNoteSaved
redirect currentRoute -- reload page after post
)
-- De-/Register Button for Lecturer
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret
formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification
| isJust registration -> do
runDB $ deleteBy $ UniqueParticipant uid cid
redirect $ currentRoute :#: noteFrag -- reload page after post
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
let currentField :: Maybe (Maybe StudyFeaturesId)
currentField = courseParticipantField . entityVal <$> mRegistration
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
let registrationFieldFrag :: Text
registrationFieldFrag = "registration-field"
regFieldWidget = wrapForm regFieldView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
, formEncoding = regFieldEnctype
, formAttrs = []
, formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag
}
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
formResult regFieldRes $ \courseParticipantField' -> do
runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ]
addMessageI Success MsgCourseStudyFeatureUpdated
redirect $ currentRoute :#: registrationFieldFrag
let regButton
| Just _ <- mRegistration = BtnDeregister
| otherwise = BtnRegister
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
let registrationButtonFrag :: Text
registrationButtonFrag = "registration-button"
regButtonWidget = wrapForm regButtonView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
, formEncoding = regButtonEnctype
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Just registrationButtonFrag
}
formResult regButtonRes $ \case
BtnDeregister
| Just (Entity pId _) <- mRegistration
-> do
runDB $ delete pId
addMessageI Info MsgCourseDeregisterOk
| otherwise -> do
actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
redirect $ CourseR tid ssh csh CUsersR
| otherwise
-> invalidArgs ["User not registered"]
BtnRegister -> do
now <- liftIO getCurrentTime
let primaryField
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
= Just featId
| otherwise
= Nothing
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
case pId of
Just _ -> do
addMessageI Success MsgCourseRegisterOk
redirect currentRoute
Nothing -> invalidArgs ["User already registered"]
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
-- generate output
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName

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

@ -287,8 +287,9 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
-- | 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 (Maybe StudyFeaturesId)
studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
studyFeaturesPrimaryFieldFor isOptional 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
@ -316,12 +317,15 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
nonEmptyOptions emptyOpt opts
| null opts = [ Option
| null opts = pure nullOption
| isOptional = nullOption : opts
| otherwise = opts
where
nullOption = Option
{ optionDisplay = emptyOpt
, optionInternalValue = Nothing
, optionExternalValue = "NoPrimaryStudyField"
} ]
| otherwise = opts
}
uploadModeField :: Field Handler UploadMode

2
src/Handler/Utils/Table/Pagination.hs
View File

@ -657,7 +657,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
return (filterRes', pagesizeRes')
let

7
src/Utils/Form.hs
View File

@ -153,7 +153,7 @@ inputReadonly :: FieldSettings site -> FieldSettings site
inputReadonly = addAttr "readonly" ""
addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "data-autosubmit" ""
addAutosubmit = addAttr "uw-auto-submit-input" ""
------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
@ -183,6 +183,8 @@ data FormIdentifier
| FIDCourseRegister
| FIDuserRights
| FIDcUserNote
| FIDcRegField
| FIDcRegButton
| FIDAdminDemo
| FIDUserDelete
| FIDCommunication
@ -340,9 +342,6 @@ combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""
autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit
-- | just Html for a Submit-Button
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
submitButtonView = buttonView BtnSubmit

55
static/js/utils/form.js
View File

@ -286,6 +286,61 @@
setup: autoSubmitButtonUtil,
});
/**
*
* Auto Submit Input Utility
* Programmatically submits forms when a certain input changes value
*
* Attribute: uw-auto-submit-input
*
* Example usage:
* <input type="text" uw-auto-submit-input />
*/
var AUTO_SUBMIT_INPUT_UTIL_NAME = 'autoSubmitInput';
var AUTO_SUBMIT_INPUT_UTIL_SELECTOR = '[uw-auto-submit-input]';
var AUTO_SUBMIT_INPUT_INITIALIZED_CLASS = 'auto-submit-input--initialized';
var autoSubmitInputUtil = function(element) {
var form;
function autoSubmit() {
form.submit();
}
function init() {
if (!element) {
throw new Error('Auto Submit Input utility needs to be passed an element!');
}
form = element.form;
if (!form) {
throw new Error('Could not determine associated form for auto submit input');
}
element.addEventListener('change', autoSubmit);
element.classList.add(AUTO_SUBMIT_INPUT_INITIALIZED_CLASS);
return {
name: AUTO_SUBMIT_INPUT_UTIL_NAME,
element: element,
destroy: function() {
element.removeEventListener('change', autoSubmit);
},
};
}
return init();
};
formUtilities.push({
name: AUTO_SUBMIT_INPUT_UTIL_NAME,
selector: AUTO_SUBMIT_INPUT_UTIL_SELECTOR,
setup: autoSubmitInputUtil,
});
/**
*
* Form Error Remover Utility

28
templates/course-user.hamlet
View File

@ -9,17 +9,16 @@
#{matnr}
$nothing
_{MsgNoMatrikelKnown}
<dt .deflist__dt>_{MsgRegisteredHeader}
$maybe date <- mRegAt
<dt .deflist__dt>_{MsgRegisteredSince}
<dd .deflist__dd>#{date}
<dt .deflist__dt>
<dd .deflist__dd>
<div .course__registration>
<a id="register-form">
<form method=post action=@{currentRoute}#register-form enctype=#{registerEnctype}>
^{registerView}
$maybe date <- mRegAt
_{MsgRegisteredSince date}
<dt .deflist__dt> _{MsgStudyTerms}
^{regButtonWidget}
$maybe _ <- mRegistration
<p>
_{MsgCourseDeregisterLecturerTip}
<dt .deflist__dt>_{MsgStudyTerms}
<dd .deflist__dd>
$if null studies
_{MsgNoStudyTermsKnown}
@ -35,15 +34,16 @@
<th .table__th>_{MsgStudyFeatureUpdate}
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
$with _ <- notUsedT studyFeaturesUser
<tr.table__row>
<tr .table__row>
<td .table__td>_{field}#{notUsedT studyFeaturesField}
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
<td .table__td>_{studyFeaturesType}
<td .table__td>#{display studyFeaturesSemester}
<td .table__td>#{hasTickmark studyFeaturesValid}
<td .table__td>^{formatTimeW SelFormatDate studyFeaturesUpdated}
$maybe _ <- mRegistration
<dt .deflist__dt>_{MsgCourseStudyFeature}
<dd .deflist__dd>^{regFieldWidget}
<section>
<a id="note-form">
<form method=post action=@{currentRoute}#note-form enctype=#{noteEnctype}>
^{noteView}
^{noteWidget}

2
templates/course.hamlet
View File

@ -83,7 +83,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
$# regForm is defined through templates/widgets/registerForm
^{regForm}
$maybe date <- mRegAt
_{MsgRegisteredSince date}
_{MsgRegisteredSince} #{date}
<dt .deflist__dt>
Material
<dd .deflist__dd>