fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

BUGFIXES: 1) Message status codes 2) Course editing could have cause uniqueness constraint violation, resulting in db exception.

Browse Source
This commit is contained in:
SJost 2017-11-27 15:59:28 +01:00
parent 70ad55f565
commit e3906672aa
6 changed files with 97 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
src/Handler/Course.hs
View File

@ -14,6 +14,7 @@ import Handler.Utils
import Data.Time import Data.Time
import qualified Data.Text as T import qualified Data.Text as T
import Data.Function ((&))
import Yesod.Form.Bootstrap3 import Yesod.Form.Bootstrap3
import Colonnade hiding (fromMaybe) import Colonnade hiding (fromMaybe)
@ -31,7 +32,7 @@ getCourseListTermR tidini = do
<$> get (TermKey tidini) <$> get (TermKey tidini)
<*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] <*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand]
when (isNothing term) $ do when (isNothing term) $ do
setMessage [shamlet| Semester #{termToText tidini} nicht gefunden. |] addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |]
redirect TermShowR redirect TermShowR
-- TODO: several runDBs per TableRow are probably too inefficient! -- TODO: several runDBs per TableRow are probably too inefficient!
let colonnadeTerms = mconcat let colonnadeTerms = mconcat
@ -115,11 +116,11 @@ postCourseShowR tid csh = do
(FormSuccess _) (FormSuccess _)
| registered -> do | registered -> do
runDB $ deleteBy $ UniqueCourseParticipant cid aid runDB $ deleteBy $ UniqueCourseParticipant cid aid
setMessage "Sie wurden abgemeldet." addMessage "info" "Sie wurden abgemeldet."
| otherwise -> do | otherwise -> do
actTime <- liftIO $ getCurrentTime actTime <- liftIO $ getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime 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 -- redirect or not?! I guess not, since we want GET now
getCourseShowR tid csh getCourseShowR tid csh
@ -154,16 +155,21 @@ courseEditHandler course = do
, Just cid <- cfCourseId res -> do , Just cid <- cfCourseId res -> do
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
let cti = termToText $ cfTerm res 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 redirect $ CourseListTermR $ cfTerm res
| fAct == formActionSave | fAct == formActionSave
, Just cid <- cfCourseId res -> do , Just cid <- cfCourseId res -> do
let tid = TermKey $ cfTerm res
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
runDB $ do updateokay <- runDB $ do
update cid exists <- getBy $ CourseTermShort tid $ cfShort res
let upokay = isNothing exists
when upokay $ update cid
[ CourseName =. cfName res [ CourseName =. cfName res
, CourseDescription =. cfDesc res , CourseDescription =. cfDesc res
, CourseLinkExternal =. cfLink 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 , CourseSchoolId =. cfSchool res
, CourseCapacity =. cfCapacity res , CourseCapacity =. cfCapacity res
, CourseRegisterFrom =. cfRegFrom res , CourseRegisterFrom =. cfRegFrom res
@ -171,9 +177,15 @@ courseEditHandler course = do
, CourseChangedBy =. aid , CourseChangedBy =. aid
, CourseChanged =. actTime , CourseChanged =. actTime
] ]
return upokay
let cti = termToText $ cfTerm res let cti = termToText $ cfTerm res
setMessage $ [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] if updateokay
redirect $ CourseListTermR $ cfTerm res 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 | fAct == formActionSave
, Nothing <- cfCourseId res -> do , Nothing <- cfCourseId res -> do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
@ -197,15 +209,12 @@ courseEditHandler course = do
(Just cid) -> do (Just cid) -> do
runDB $ insert_ $ Lecturer aid cid runDB $ insert_ $ Lecturer aid cid
let cti = termToText $ cfTerm res 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 redirect $ CourseListTermR $ cfTerm res
Nothing -> do Nothing -> do
let cti = termToText $ cfTerm res let cti = termToText $ cfTerm res
setMessage $ [shamlet| addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|]
<div .alert .alert-danger> (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."
Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.
|]
(FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren."
_other -> return () _other -> return ()
let formTitle = "Kurs editieren/anlegen" :: Text let formTitle = "Kurs editieren/anlegen" :: Text
let actionUrl = CourseEditR let actionUrl = CourseEditR
@ -260,16 +269,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
<$> aopt hiddenField "KursId" (cfCourseId <$> template) <$> aopt hiddenField "KursId" (cfCourseId <$> template)
<*> areq textField (set "Name") (cfName <$> template) <*> areq textField (fsb "Name") (cfName <$> template)
<*> aopt htmlField (set "Beschreibung") (cfDesc <$> template) <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template)
<*> aopt urlField (set "Homepage") (cfLink <$> template) <*> aopt urlField (fsb "Homepage") (cfLink <$> template)
<*> areq textField (setToolt "Kürzel" "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) <*> areq textField (fsb "Kürzel"
<*> areq termExistsField (set "Semester") (cfTerm <$> template) -- & addAttr "disabled" "disabled"
<*> areq (selectField schools) (set "Institut") (cfSchool <$> template) & setTooltip "Muss innerhalb des Semesters eindeutig sein")
<*> aopt (natField "Kapazität") (set "Kapazität") (cfCapacity <$> template) (cfShort <$> template)
<*> areq checkBoxField (set "Anmeldung") (cfHasReg <$> template) <*> areq termExistsField (fsb "Semester") (cfTerm <$> template)
<*> aopt utcTimeField (set "Anmeldung von:") (cfRegFrom <$> template) <*> areq (selectField schools) (fsb "Institut") (cfSchool <$> template)
<*> aopt utcTimeField (set "Anmeldung bis:") (cfRegTo <$> 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)) -- <* bootstrapSubmit (bsSubmit (show cid))
return $ case result of return $ case result of
FormSuccess courseResult FormSuccess courseResult
@ -287,20 +299,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do
) )
_ -> (result, widget) _ -> (result, widget)
where where
cid :: Maybe CourseId -- cid :: Maybe CourseId
cid = join $ cfCourseId <$> template -- 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 }
-- schools :: GHandler UniWorX UniWorX (OptionList SchoolId) -- schools :: GHandler UniWorX UniWorX (OptionList SchoolId)
schools = do schools = do
entities <- runDB $ selectList [] [Asc SchoolShorthand] entities <- runDB $ selectList [] [Asc SchoolShorthand]

2
src/Handler/Home.hs
View File

@ -52,7 +52,7 @@ postHomeR = do
((btnResult,_), _) <- runFormPost $ buttonForm ((btnResult,_), _) <- runFormPost $ buttonForm
case btnResult of case btnResult of
(FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> setMessage "Knopf Mathematik erkannt" (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
_other -> return () _other -> return ()
getHomeR getHomeR

4
src/Handler/Submission.hs
View File

@ -84,7 +84,7 @@ postSubmissionListR = do
runDB $ do runDB $ do
case uploadResult of case uploadResult of
FormMissing -> return () FormMissing -> return ()
FormFailure _ -> setMessage "Bitte Eingabe korrigieren." FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren."
FormSuccess (isUpdate, fInfo) -> do FormSuccess (isUpdate, fInfo) -> do
userId <- lift requireAuthId userId <- lift requireAuthId
let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) () 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 submission@Submission{..} <- get404 submissionId
case uploadResult of case uploadResult of
FormMissing -> return submission FormMissing -> return submission
FormFailure _ -> submission <$ setMessage "Bitte Eingabe korrigieren." FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren."
FormSuccess (isUpdate, fInfo) -> do FormSuccess (isUpdate, fInfo) -> do
userId <- lift requireAuthId userId <- lift requireAuthId
let mimeType = defaultMimeLookup (fileName fInfo) let mimeType = defaultMimeLookup (fileName fInfo)

6
src/Handler/Term.hs
View File

@ -96,18 +96,18 @@ termEditHandler term = do
runDB $ delete (TermKey $ termName res) runDB $ delete (TermKey $ termName res)
let tid = termToText $ termName res let tid = termToText $ termName res
let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht." let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht."
setMessage $ [shamlet| #{msg} |] addMessage "warning" [shamlet| #{msg} |]
redirect TermShowR redirect TermShowR
| fAct == formActionSave -> do | fAct == formActionSave -> do
-- term <- runDB $ get $ TermKey termName -- term <- runDB $ get $ TermKey termName
runDB $ repsert (TermKey $ termName res) res runDB $ repsert (TermKey $ termName res) res
let tid = termToText $ termName res let tid = termToText $ termName res
let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
setMessage [shamlet| #{msg} |] addMessage "success" [shamlet| #{msg} |]
redirect TermShowR redirect TermShowR
| otherwise -> redirect TermShowR | otherwise -> redirect TermShowR
(FormMissing,_) -> return () (FormMissing,_) -> return ()
(FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren." (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."
let formTitle = "Semester editieren/anlegen" :: Text let formTitle = "Semester editieren/anlegen" :: Text
let actionUrl = TermEditR let actionUrl = TermEditR
let formActions = defaultFormActions let formActions = defaultFormActions

50
src/Handler/Utils/Form.hs
View File

@ -245,3 +245,53 @@ utcTimeField = Field
showTime :: UTCTime -> Text showTime :: UTCTime -> Text
showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat) 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 }

4
templates/default-layout.hamlet
View File

@ -41,8 +41,8 @@
<li .active>#{title} <li .active>#{title}
$forall (status, msg) <- mmsgs $forall (status, msg) <- mmsgs
$with status' <- bool (const "info") id (status == "") status $with status2 <- bool status "info" (status == "")
<div class="alert alert-#{status'}">#{msg} <div class="alert alert-#{status2}">#{msg}
$if (Just HomeR == mcurrentRoute) $if (Just HomeR == mcurrentRoute)