Fix #81

src/Handler/Course.hs

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

src/Model.hs

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

src/Utils/DB.hs

@@ -30,7 +30,7 @@ existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity re
 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
        ,Eq (Unique record)
        ,PersistRecordBackend record backend