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

Merge branch 'master' of https://gitlab.cip.ifi.lmu.de/jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2019-07-17 17:24:12 +02:00
commit ddda584b08
9 changed files with 28 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
frontend/src/utils/inputs/inputs.scss
View File

@ -36,11 +36,9 @@
font-size: 0.9rem;
}
.form-group--required {
.form-group-label__caption::after {
content: ' *';
color: var(--color-error);
}
.form-group--required .form-group-label__caption::after, .form-group__required-marker::before {
content: ' *';
color: var(--color-error);
}
.form-group--optional {

1
messages/uniworx/de.msg
View File

@ -523,6 +523,7 @@ NotificationSettings: Erwünschte Benachrichtigungen
FormNotifications: Benachrichtigungen
FormBehaviour: Verhalten
FormCosmetics: Oberfläche
FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
ActiveAuthTags: Aktivierte Authorisierungsprädikate

1
src/Auth/Dummy.hs
View File

@ -32,6 +32,7 @@ dummyLogin :: ( YesodAuth site
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site AFormMessage
, RenderMessage site DummyMessage
, Button site ButtonSubmit
) => AuthPlugin site

3
src/Auth/LDAP.hs
View File

@ -73,6 +73,7 @@ campusLogin :: forall site.
( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site AFormMessage
, Button site ButtonSubmit
) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
@ -91,7 +92,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
Ldap.bind ldap ldapDn ldapPassword
searchResults <- findUser conf ldap campusIdent [userPrincipalName]
case searchResults of
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
| Just [principalName] <- lookup userPrincipalName userAttrs
, Right credsIdent <- Text.decodeUtf8' principalName
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)

1
src/Auth/PWHash.hs
View File

@ -40,6 +40,7 @@ hashLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site AFormMessage
, Button site ButtonSubmit
) => PWHashAlgorithm -> AuthPlugin site
hashLogin pwHashAlgo = AuthPlugin{..}

2
src/Foundation.hs
View File

@ -294,6 +294,8 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
in verbMap . splitCamel
embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)

14
src/Handler/Exam.hs
View File

@ -699,7 +699,7 @@ 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
@ -865,10 +865,10 @@ instance CsvColumnsExplained ExamUserTableCsv where
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
, ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses )
, ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
, ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax )
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
, ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses )
, ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
, ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax )
]
data ExamUserAction = ExamUserDeregister
@ -923,7 +923,7 @@ postEUsersR tid ssh csh examn = do
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
]
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserSurname queryUser
@ -1032,7 +1032,7 @@ postERegisterR tid ssh csh examn = do
runDB $ do
deleteBy $ UniqueExamRegistration eId uid
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
addMessageI Success $ MsgExamDeregisteredSuccess examn
addMessageI Info $ 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! Maybe make it even a warning?!
redirect $ CExamR tid ssh csh examn EShowR
invalidArgs ["Register/Deregister button required"]

11
src/Utils/Form.hs
View File

@ -602,7 +602,7 @@ fileFieldMultiple = Field
[whamlet|
$newline never
<input type="file" uw-file-input id=#{id'} name=#{name} *{attrs} multiple :isReq:required="required">
|]
|]
, fieldEnctype = Multipart
}
@ -652,13 +652,16 @@ wrapForm' btn formWidget FormSettings{..} = do
-- | Use this type to pass information to the form template
data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport
renderAForm :: Monad m => FormLayout -> FormRender m a
data AFormMessage = MsgAFormFieldRequiredTip
renderAForm :: (RenderMessage (HandlerSite m) AFormMessage, Monad m) => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
(res, ($ []) -> fieldViews) <- aFormToForm aform
let widget = $(widgetFile "widgets/aform/aform")
let formHasRequiredFields = any fvRequired fieldViews
widget = $(widgetFile "widgets/aform/aform")
return (res, widget)
renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here)
renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here)
(Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
renderWForm formLayout = renderAForm formLayout . wFormToAForm

4
templates/widgets/aform/aform.hamlet
View File

@ -22,3 +22,7 @@ $case formLayout
^{fvInput view}
$maybe err <- fvErrors view
<div .form-error>#{err}
$if formHasRequiredFields
<div .form-section-title>
<span .form-group__required-marker>
_{MsgAFormFieldRequiredTip}