diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3ad039d2b..88f66110f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -125,7 +125,7 @@ CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet CourseHomepageExternal: Externe Homepage CourseShorthand: Kürzel -CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein +CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein. Wird verbatim in die Url der Kursseite übernommen. CourseSemester: Semester CourseSchool: Institut CourseSchoolShort: Institut @@ -227,6 +227,7 @@ CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen CourseAllocationRequiresCapacity: Bei Teilnahme an einer Zentralanmeldung muss eine Kurskapazität angegeben werden CourseAllocationTermMustMatch: Kurs-Semester muss mit Semester der Zentralanmeldung übereinstimmen CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Zentralanmeldung teilnimmt, darf nicht nachträglich verändert werden +CourseShorthandTooLong: Lange Kurskürzel können zu Problemen bei der Darstellung und der Kommunikation mit den Studierenden führen. Bitte wählen Sie ein weniger langes Kürzel, falls möglich. CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 522b10b06..4386e2bb3 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -18,6 +18,7 @@ import Data.Map ((!)) import qualified Data.Map as Map import Control.Monad.Trans.Writer (execWriterT) +import qualified Control.Monad.State.Class as State import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -99,7 +100,7 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm -makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do +makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring @@ -255,15 +256,15 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) - <*> areq ciField (fslI MsgCourseName) (cfName <$> template) - <*> areq ciField (fslI MsgCourseShorthand + <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) + <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana1, Rust, …" -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben" & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) - <*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL") + <*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal "Optionale externe URL") (cfLink <$> template) <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) <* aformSection MsgCourseFormSectionRegistration @@ -276,7 +277,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) - <*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) + <*> aopt (textField & cfStrip) (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) & setTooltip MsgCourseSecretTip) (cfSecret <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) @@ -286,33 +287,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do & setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil) <* aformSection MsgCourseFormSectionAdministration <*> lecturerForm - errorMsgs' <- traverse validateCourse result - return $ case errorMsgs' of - FormSuccess errorMsgs - | not $ null errorMsgs -> - (FormFailure errorMsgs, - [whamlet| -
-
-

Fehler: -
    - $forall errmsg <- errorMsgs -
  • #{errmsg} - ^{widget} - |] - ) - _ -> (result, widget) + return (result, widget) -validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] -validateCourse CourseForm{..} = do +validateCourse :: FormValidator CourseForm (YesodDB UniWorX) () +validateCourse = do + CourseForm{..} <- State.get + now <- liftIO getCurrentTime uid <- liftHandlerT requireAuthId userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR - MsgRenderer mr <- getMsgRenderer - allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust + allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust - oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> liftHandlerT . runDB $ do + oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> lift $ do prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse @@ -324,30 +311,22 @@ validateCourse CourseForm{..} = do | otherwise -> return Nothing + guardValidation MsgCourseRegistrationEndMustBeAfterStart + $ NTop cfRegFrom <= NTop cfRegTo + guardValidation MsgCourseDeregistrationEndMustBeAfterStart + $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil + unless userAdmin $ + guardValidation MsgCourseUserMustBeLecturer + $ anyOf (traverse . _Right . _1) (== uid) cfLecturers + guardValidation MsgCourseAllocationRequiresCapacity + $ is _Nothing cfAllocation || is _Just cfCapacity + guardValidation MsgCourseAllocationTermMustMatch + $ maybe True (== cfTerm) allocationTerm + guardValidation MsgCourseAllocationCapacityMayNotBeChanged + $ maybe True (== cfCapacity) oldAllocatedCapacity - return - [ mr msg | (False, msg) <- - [ - ( NTop cfRegFrom <= NTop cfRegTo - , MsgCourseRegistrationEndMustBeAfterStart - ) - , - ( NTop cfRegFrom <= NTop cfDeRegUntil - , MsgCourseDeregistrationEndMustBeAfterStart - ) - , ( bool (anyOf (traverse . _Right . _1) (== uid) cfLecturers) True userAdmin - , MsgCourseUserMustBeLecturer - ) - , ( is _Nothing cfAllocation || is _Just cfCapacity - , MsgCourseAllocationRequiresCapacity - ) - , ( maybe True (== cfTerm) allocationTerm - , MsgCourseAllocationTermMustMatch - ) - , ( maybe True (== cfCapacity) oldAllocatedCapacity - , MsgCourseAllocationCapacityMayNotBeChanged - ) - ] ] + warnValidation MsgCourseShorthandTooLong + $ length (CI.original cfShort) <= 10 getCourseNewR :: Handler Html -- call via toTextUrl diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index ac4167be2..cdfc86cb1 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -160,8 +160,8 @@ examOccurrenceForm prev = wFormToAForm $ do where examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) - (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) - (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) + (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (eofName <$> mPrev) + (eofRoomRes, eofRoomView) <- mpreq (textField & cfStrip) ("" & addName (nudge "room")) (eofRoom <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start") & addDatepickerPositionAttr DPBottom) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end") & addDatepickerPositionAttr DPBottom) (eofEnd <$> mPrev) @@ -202,7 +202,7 @@ examPartsForm prev = wFormToAForm $ do where examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) - (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) @@ -345,7 +345,7 @@ validateExam = do forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart - warn_Validation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 689997aa9..3c8a4d150 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -62,8 +62,8 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do _ -> MsgMaterialVisibleFromTip flip (renderAForm FormStandard) html $ MaterialForm - <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) - <*> aopt (ciField & addDatalist typeOptions) + <$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template) + <*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions) (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) (mfType <$> template) <*> aopt htmlField (fslpI MsgMaterialDescription "Html") diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 19f2646f4..f97130264 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -67,8 +67,8 @@ data SchoolForm = SchoolForm mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm - <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort) - <*> areq ciField (fslI MsgSchoolName) (sfName <$> template) + <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort) + <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template) <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template)) where ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text)) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index cda01b02a..331922434 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -99,7 +99,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm - <$> areq ciField (fslI MsgSheetName) (sfName <$> template) + <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) <* aformSection MsgSheetFormTimes <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 35e40a200..babe6563f 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -23,8 +23,6 @@ import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI -import qualified Data.Text as Text - import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) @@ -324,12 +322,12 @@ tutorialForm cid template html = do miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") flip (renderAForm FormStandard) html $ TutorialForm - <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) - <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) + <$> areq (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) + <*> areq (textField & cfStrip & cfCI & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) - <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) + <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip ) (tfRegisterFrom <$> template) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 52e1900f7..feb7d21c9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -462,7 +462,7 @@ ciField :: ( Textual t , Monad m , RenderMessage (HandlerSite m) FormMessage ) => Field m (CI t) -ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField +ciField = convertField repack repack textField & cfCI pathPieceField :: ( PathPiece a , Monad m @@ -659,9 +659,23 @@ fileFieldMultiple = Field , fieldEnctype = Multipart } +guardField :: Functor m => (a -> Bool) -> Field m a -> Field m a +guardField p field = field { fieldParse = \ts fs -> fieldParse field ts fs <&> \case + Right (Just x) + | p x -> Right $ Just x + | otherwise -> Right Nothing + other -> other + } + checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b) -> (b -> a) -> Field m a -> Field m b checkMap f = checkMMap (return . f) +cfStrip :: (Functor m, Textual t) => Field m t -> Field m t +cfStrip = guardField (not . T.null . repack) . convertField (repack . T.strip . repack) id + +cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s) +cfCI = convertField CI.mk CI.original + selectField' :: ( Eq a , RenderMessage (HandlerSite m) FormMessage @@ -959,6 +973,7 @@ deriving newtype instance MonadFix m => MonadFix (FormValidator r m) deriving newtype instance MonadResource m => MonadResource (FormValidator r m) deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m) deriving newtype instance MonadIO m => MonadIO (FormValidator r m) +deriving newtype instance MonadLogger m => MonadLogger (FormValidator r m) instance MonadBase b m => MonadBase b (FormValidator r m) where liftBase = lift . liftBase instance MonadTrans (FormValidator r) where @@ -1010,13 +1025,13 @@ guardValidationM :: ( MonadHandler m guardValidationM = (. lift) . (=<<) . guardValidation -- | like `guardValidation`, but issues a warning instead -warn_Validation :: ( MonadHandler m +warnValidation :: ( MonadHandler m , RenderMessage (HandlerSite m) msg ) => msg -- ^ Message describing violation -> Bool -- ^ @False@ iff constraint is violated -> FormValidator r m () -warn_Validation msg isValid = unless isValid $ addMessageI Warning msg +warnValidation msg isValid = unless isValid $ addMessageI Warning msg -----------------------