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

Fix #81

Browse Source
This commit is contained in:
SJost 2018-08-02 15:08:28 +02:00
parent a67a94468c
commit f6ade63d1e
3 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Handler/Course.hs
View File

@ -308,16 +308,12 @@ courseEditHandler isGet course = do
cid <- decrypt cID cid <- decrypt cID
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|] -- addMessage "debug" [shamlet| #{show res}|]
runDB $ do success <- runDB $ do
old <- get cid old <- get cid
case old of case old of
Nothing -> addMessageI "error" $ MsgInvalidInput Nothing -> addMessageI "error" MsgInvalidInput $> False
(Just oldCourse) -> do (Just oldCourse) -> do
-- existing <- getBy $ CourseTermShort tid csh updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
-- if ((entityKey <$> existing) /= Just cid)
-- then addMessageI "danger" $ MsgCourseEditDupShort tid csh
-- else do
_updOkay <- replace cid ( -- TODO replaceUnique requires Eq?!
Course { courseName = cfName res Course { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
@ -332,12 +328,13 @@ courseEditHandler isGet course = do
, courseDeregisterUntil = cfDeRegUntil res , courseDeregisterUntil = cfDeRegUntil res
} }
) )
insert_ $ CourseEdit aid now cid case updOkay of
-- if (isNothing updOkay) (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False
-- then do Nothing -> do
addMessageI "success" $ MsgCourseEditOk tid csh insert_ $ CourseEdit aid now cid
-- redirect $ TermCourseListR tid addMessageI "success" $ MsgCourseEditOk tid csh
-- else addMessageI "danger" $ MsgCourseEditDupShort tid csh return True
when success $ redirect $ CourseR tid csh CShowR
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) -> return () (FormMissing) -> return ()

6
src/Model.hs
View File

@ -8,6 +8,9 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
module Model module Model
( module Model ( module Model
, module Model.Types , module Model.Types
@ -31,6 +34,9 @@ import Data.CaseInsensitive (CI)
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"] share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
$(persistFileWith lowerCaseSettings "models") $(persistFileWith lowerCaseSettings "models")
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course)
migrateAll :: Migration migrateAll :: Migration
migrateAll = do migrateAll = do
migrateEnableExtension "citext" migrateEnableExtension "citext"

2
src/Utils/DB.hs
View File

@ -30,7 +30,7 @@ existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity re
existsBy = fmap isJust . getBy existsBy = fmap isJust . getBy
myReplaceUnique myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
:: (MonadIO m :: (MonadIO m
,Eq (Unique record) ,Eq (Unique record)
,PersistRecordBackend record backend ,PersistRecordBackend record backend