feat(course-edit): warn about long shorthands
Also make sure text input is stripped of whitespace
This commit is contained in:
Gregor Kleen
parent
1d8630663a
commit
80cb16a40f
@ -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.
|
||||
|
||||
|
||||
@ -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|
|
||||
<div class="alert alert-danger">
|
||||
<div class="alert__content">
|
||||
<h4> Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
-----------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user