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

frontend/src/utils/inputs/inputs.scss

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

messages/uniworx/de.msg

@@ -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
 

src/Auth/Dummy.hs

@@ -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

src/Auth/LDAP.hs

@@ -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)

src/Auth/PWHash.hs

@@ -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{..}

src/Foundation.hs

@@ -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" <>)

src/Handler/Exam.hs

@@ -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    ) 
+    , ('csvEUserExercisePoints   , MsgCsvColumnExamUserExercisePoints    )
-    , ('csvEUserExercisePasses   , MsgCsvColumnExamUserExercisePasses    ) 
+    , ('csvEUserExercisePasses   , MsgCsvColumnExamUserExercisePasses    )
-    , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) 
+    , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
-    , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) 
+    , ('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"]

src/Utils/Form.hs

@@ -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
 

templates/widgets/aform/aform.hamlet

@@ -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}