feat(course-edit): warn about long shorthands

Also make sure text input is stripped of whitespace

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.
 

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 (textField & cfStrip & cfCI) (fslI MsgCourseName)                             (cfName       <$> template)
-      <*> areq ciField (fslI MsgCourseShorthand
+      <*> 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 (result, widget)
-    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)
 
 
-validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
+validateCourse :: FormValidator CourseForm (YesodDB UniWorX) ()
-validateCourse CourseForm{..} = do
+validateCourse = do
+  CourseForm{..} <- State.get
+
   now <- liftIO getCurrentTime
   uid <- liftHandlerT requireAuthId
   userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
-  MsgRenderer mr <- getMsgRenderer
+  allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
-  allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . 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
+  warnValidation MsgCourseShorthandTooLong
-    [ mr msg | (False, msg) <-
+    $ length (CI.original cfShort) <= 10
-        [
-          ( 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
-          )
-        ] ]
   
 
 getCourseNewR :: Handler Html -- call via toTextUrl

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)
+      (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (eofName <$> mPrev)
-      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> 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)

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)
+      <$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName)         (mfName        <$> template)
-      <*> aopt (ciField & addDatalist typeOptions)
+      <*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions)
                               (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
                                                              (mfType        <$> template)
       <*> aopt htmlField      (fslpI MsgMaterialDescription "Html")

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)
+  <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
-  <*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
+  <*> 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))

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)

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 (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
-    <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> 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)

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