BUGFIXES: 1) Message status codes 2) Course editing could have cause uniqueness constraint violation, resulting in db exception.
This commit is contained in:
SJost
parent
70ad55f565
commit
e3906672aa
@ -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|
|
||||
<div .alert .alert-danger>
|
||||
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]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 }
|
||||
|
||||
|
||||
@ -41,8 +41,8 @@
|
||||
<li .active>#{title}
|
||||
|
||||
$forall (status, msg) <- mmsgs
|
||||
$with status' <- bool (const "info") id (status == "") status
|
||||
<div class="alert alert-#{status'}">#{msg}
|
||||
$with status2 <- bool status "info" (status == "")
|
||||
<div class="alert alert-#{status2}">#{msg}
|
||||
|
||||
|
||||
$if (Just HomeR == mcurrentRoute)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user