diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a0077ce64..727ad0ef4 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -14,6 +14,7 @@ import Handler.Utils import Data.Time import qualified Data.Text as T +import Data.Function ((&)) import Yesod.Form.Bootstrap3 import Colonnade hiding (fromMaybe) @@ -31,7 +32,7 @@ getCourseListTermR tidini = do <$> get (TermKey tidini) <*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] when (isNothing term) $ do - setMessage [shamlet| Semester #{termToText tidini} nicht gefunden. |] + addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |] redirect TermShowR -- TODO: several runDBs per TableRow are probably too inefficient! let colonnadeTerms = mconcat @@ -115,11 +116,11 @@ postCourseShowR tid csh = do (FormSuccess _) | registered -> do runDB $ deleteBy $ UniqueCourseParticipant cid aid - setMessage "Sie wurden abgemeldet." + addMessage "info" "Sie wurden abgemeldet." | otherwise -> do actTime <- liftIO $ getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime - when (isJust regOk) $ setMessage "Erfolgreich angemeldet!" + when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" -- redirect or not?! I guess not, since we want GET now getCourseShowR tid csh @@ -154,16 +155,21 @@ courseEditHandler course = do , Just cid <- cfCourseId res -> do runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! let cti = termToText $ cfTerm res - setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht! |] + addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] redirect $ CourseListTermR $ cfTerm res | fAct == formActionSave , Just cid <- cfCourseId res -> do + let tid = TermKey $ cfTerm res actTime <- liftIO getCurrentTime - runDB $ do - update cid + updateokay <- runDB $ do + exists <- getBy $ CourseTermShort tid $ cfShort res + let upokay = isNothing exists + when upokay $ update cid [ CourseName =. cfName res , CourseDescription =. cfDesc res , CourseLinkExternal =. cfLink res + , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?! + , CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?! , CourseSchoolId =. cfSchool res , CourseCapacity =. cfCapacity res , CourseRegisterFrom =. cfRegFrom res @@ -171,9 +177,15 @@ courseEditHandler course = do , CourseChangedBy =. aid , CourseChanged =. actTime ] + return upokay let cti = termToText $ cfTerm res - setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] - redirect $ CourseListTermR $ cfTerm res + if updateokay + then do + addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] + redirect $ CourseListTermR $ cfTerm res + else do + addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden. + \ Es gibt bereits einen anderen Kurs mit diesem Kürzel in diesem Semester.|] | fAct == formActionSave , Nothing <- cfCourseId res -> do actTime <- liftIO getCurrentTime @@ -197,15 +209,12 @@ courseEditHandler course = do (Just cid) -> do runDB $ insert_ $ Lecturer aid cid let cti = termToText $ cfTerm res - setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde angelegt. |] + addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] redirect $ CourseListTermR $ cfTerm res Nothing -> do let cti = termToText $ cfTerm res - setMessage $ [shamlet| -
- Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}. - |] - (FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren." + addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] + (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." _other -> return () let formTitle = "Kurs editieren/anlegen" :: Text let actionUrl = CourseEditR @@ -260,16 +269,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> aopt hiddenField "KursId" (cfCourseId <$> template) - <*> areq textField (set "Name") (cfName <$> template) - <*> aopt htmlField (set "Beschreibung") (cfDesc <$> template) - <*> aopt urlField (set "Homepage") (cfLink <$> template) - <*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) - <*> areq termExistsField (set "Semester") (cfTerm <$> template) - <*> areq (selectField schools) (set "Institut") (cfSchool <$> template) - <*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template) - <*> areq checkBoxField (set "Anmeldung") (cfHasReg <$> template) - <*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template) - <*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> template) + <*> areq textField (fsb "Name") (cfName <$> template) + <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) + <*> aopt urlField (fsb "Homepage") (cfLink <$> template) + <*> areq textField (fsb "Kürzel" + -- & addAttr "disabled" "disabled" + & setTooltip "Muss innerhalb des Semesters eindeutig sein") + (cfShort <$> template) + <*> areq termExistsField (fsb "Semester") (cfTerm <$> template) + <*> areq (selectField schools) (fsb "Institut") (cfSchool <$> template) + <*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) + <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) + <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) + <*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template) -- <* bootstrapSubmit (bsSubmit (show cid)) return $ case result of FormSuccess courseResult @@ -287,20 +299,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do ) _ -> (result, widget) where - cid :: Maybe CourseId - cid = join $ cfCourseId <$> template - - set :: Text -> FieldSettings site - set = bfs - - setAttrs :: Text -> [(Text,Text)] -> FieldSettings site - setAttrs t attrs = - let ifs = bfs t in ifs { fsAttrs= attrs++(fsAttrs ifs) } - - setToolt :: Text -> String -> FieldSettings site - setToolt t tt = - let ifs = bfs t in ifs { fsTooltip= Just $ fromString tt } - +-- cid :: Maybe CourseId +-- cid = join $ cfCourseId <$> template +-- -- schools :: GHandler UniWorX UniWorX (OptionList SchoolId) schools = do entities <- runDB $ selectList [] [Asc SchoolShorthand] diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 82ea20ded..d0b97fca0 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -52,7 +52,7 @@ postHomeR = do ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" - (FormSuccess CreateMath) -> setMessage "Knopf Mathematik erkannt" + (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt" _other -> return () getHomeR diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index ad7e9f3bc..f9aec1702 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -84,7 +84,7 @@ postSubmissionListR = do runDB $ do case uploadResult of FormMissing -> return () - FormFailure _ -> setMessage "Bitte Eingabe korrigieren." + FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren." FormSuccess (isUpdate, fInfo) -> do userId <- lift requireAuthId let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) () @@ -231,7 +231,7 @@ postSubmissionR cID = do submission@Submission{..} <- get404 submissionId case uploadResult of FormMissing -> return submission - FormFailure _ -> submission <$ setMessage "Bitte Eingabe korrigieren." + FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren." FormSuccess (isUpdate, fInfo) -> do userId <- lift requireAuthId let mimeType = defaultMimeLookup (fileName fInfo) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index e56599863..f468c88c6 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -96,18 +96,18 @@ termEditHandler term = do runDB $ delete (TermKey $ termName res) let tid = termToText $ termName res let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht." - setMessage $ [shamlet| #{msg} |] + addMessage "warning" [shamlet| #{msg} |] redirect TermShowR | fAct == formActionSave -> do -- term <- runDB $ get $ TermKey termName runDB $ repsert (TermKey $ termName res) res let tid = termToText $ termName res let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." - setMessage [shamlet| #{msg} |] + addMessage "success" [shamlet| #{msg} |] redirect TermShowR | otherwise -> redirect TermShowR (FormMissing,_) -> return () - (FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren." + (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." let formTitle = "Semester editieren/anlegen" :: Text let actionUrl = TermEditR let formActions = defaultFormActions diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 89e34f284..da0c56050 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -245,3 +245,53 @@ utcTimeField = Field showTime :: UTCTime -> Text showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat) + + +fsb :: Text -> FieldSettings site +fsb = bfs -- Just to avoid annoying Ambiguous Type Errors + +addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site +addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) } + where + newAttrs :: [(Text,Text)] -> [(Text,Text)] + newAttrs [] = [(attr,valu)] + newAttrs (p@(a,v):t) + | attr==a = (a,T.append valu $ cons ' ' v):t + | otherwise = p:(newAttrs t) + +addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site +addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) } + where + newAttrs :: [(Text,Text)] -> [(Text,Text)] + newAttrs [] = [(attr,T.intercalate " " valus)] + newAttrs (p@(a,v):t) + | attr==a = (a,T.intercalate " " (v:valus)):t + | otherwise = p:(newAttrs t) + +addClass :: Text -> FieldSettings site -> FieldSettings site +addClass = addAttr "class" + +addClasses :: [Text] -> FieldSettings site -> FieldSettings site +addClasses = addAttrs "class" + +addName :: Text -> FieldSettings site -> FieldSettings site +addName nm fs = fs { fsName = Just nm } + +addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site +addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) } + +addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site +addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) } + + +setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated +setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) } + +setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated +setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) } + +setTooltip :: String -> FieldSettings site -> FieldSettings site +setTooltip tt fs + | null tt = fs { fsTooltip = Nothing } + | otherwise = fs { fsTooltip = Just $ fromString tt } + diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 46a2420c1..14430ab61 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -41,8 +41,8 @@
  • #{title} $forall (status, msg) <- mmsgs - $with status' <- bool (const "info") id (status == "") status -
    #{msg} + $with status2 <- bool status "info" (status == "") +
    #{msg} $if (Just HomeR == mcurrentRoute)