Code cleaning and bug fixes towards #187

messages/uniworx/de.msg

@@ -41,10 +41,10 @@ CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
-CourseNewOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
+CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
-CourseEditOk       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
+CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert.
-CourseNewDupShort  tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
-CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
 TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
@@ -52,7 +52,7 @@ CourseListTitle: Alle Kurse
 TermCourseListTitle   tid@TermId: Kurse #{display tid}
 TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
 CourseNewHeading: Neuen Kurs anlegen
-CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
+CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
 CourseMembersCount num@Int64: #{display num}
@@ -71,19 +71,23 @@ CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
 CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
 
+NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
+NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
+NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
+NoSuchCourse: Keinen passenden Kurs gefunden.
 
 Sheet: Blatt
-SheetList          tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
+SheetList          tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter
-SheetNewHeading    tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
+SheetNewHeading    tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen
-SheetNewOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
+SheetNewOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{csh} erfolgreich erstellt.
-SheetTitle         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetTitle         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
-SheetTitleNew      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand                    : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
+SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand                    : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
-SheetEditHead      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
+SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
-SheetEditOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
+SheetEditOk        tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
-SheetNameDup       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
+SheetNameDup       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
-SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
+SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
-SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
+SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
 
 SheetUploadMode: Abgabe von Dateien
 SheetExercise: Aufgabenstellung
@@ -117,12 +121,12 @@ Deadline: Abgabe
 Done: Eingereicht
 
 Submission: Abgabenummer
-SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
+SubmissionsCourse tid@TermId ssh@SchoolId csh@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{csh}
 SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName}
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
-SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
+SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
-CorrectionHead     tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
+CorrectionHead     tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
 SubmissionMember g@Int: Mitabgebende(r) ##{display g}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
@@ -164,7 +168,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
 
 AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
-SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 Corrector: Korrektor
 Correctors: Korrektoren

src/Handler/Course.hs

@@ -20,6 +20,7 @@ import Import
 import Control.Lens
 import Utils.Lens
 import Utils.TH
+-- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
 
@@ -28,6 +29,7 @@ import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -317,28 +319,51 @@ getCourseNewR = do
   params <- runInputGetResult $ (,,)
             <$> ireq ciTextField "csh"
             <*> iopt   textField "tid"
-            <*> iopt ciTextField "sid"
+            <*> iopt ciTextField "ssh"
-  template <- case params of
+  let noTemplateAction = courseEditHandler True Nothing
-    FormMissing      -> return Nothing
+  case params of
-    FormFailure []   -> return Nothing
+    FormMissing      -> noTemplateAction
-    FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml) >> return Nothing
+    FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
-    FormSuccess (csh,mbTid,mbSid) -> do
+                        >> noTemplateAction
-      oldCourses <- runDB $ do
+    FormSuccess (csh,mbTid,mbSsh) -> do
-        E.select $ E.from $ \(course `E.InnerJoin` lecturer) -> do
+      tid <- ifJustM Nothing mbTid $ \tid ->
-          E.on     $ course   E.^. CourseSchool     E.==. lecturer E.^. UserLecturerSchool
+        case termFromText tid of
-          E.where_ $ course   E.^. CourseShorthand  E.==. E.val csh
+          Left err -> addMessage "error" (toHtml err) >> return Nothing
-              E.&&.  lecturer E.^. UserLecturerUser E.==. E.val uid      -- only search courses for lecturer's school (admin does not help here)
+          Right t  -> return $ Just $ TermKey t
-          whenIsJust (SchoolKey <$> mbSid)   $
+      getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh
-            \sid -> E.where_ $ course E.^. CourseSchool E.==. E.val sid
+
-          whenIsJust (mbTid >>= tidFromText) $
+getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html
-            \tid -> E.where_ $ course E.^. CourseTerm   E.==. E.val tid
+getCourseNewTemplateR mbTid mbSsh csh = do
-          let courseCreated c = E.sub_select . E.from $ \edit -> do
+  uid <- requireAuthId
-                E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+  oldCourses <- runDB $ do
-                return $ E.min_ $ edit E.^. CourseEditTime               -- oldest edit must be creation
+    E.select $ E.from $ \(course) -> do
-          E.orderBy [E.desc $ courseCreated course]                      -- most recent courses
+      E.where_                            $ course E.^. CourseShorthand  E.==. E.val csh
-          E.limit 1
+      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
-          return course
+      whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
-      return $ listToMaybe oldCourses
+      let lecturersSchool =
+            E.exists $ E.from $ \lecturer -> do
+              E.where_ $ lecturer E.^. UserLecturerUser   E.==. E.val uid
+                  E.&&.  lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+      let courseCreated c =
+            E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+              E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+              return $ E.min_ $ edit E.^. CourseEditTime
+      E.orderBy [ E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer schools of lecturer
+                , E.desc $ courseCreated course]                                                         -- most recent created course
+      E.limit 1
+      return course
+  template <- case listToMaybe oldCourses of
+    t@(Just _) -> return t -- TODO: modify template, eg. current TID
+    Nothing -> do
+      (tidOk,sshOk,cshOk) <- runDB $ (,,)
+        <$> ifJustM True mbTid existsKey
+        <*> ifJustM True mbSsh existsKey
+        <*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+      unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+      unless sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since tidOk==True otherwise
+      unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
+      when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
+      return Nothing
   courseEditHandler True template
 
 postCourseNewR :: Handler Html

src/Utils.hs

@@ -300,6 +300,13 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+ifJustM :: Monad m => b -> Maybe a -> (a -> m b) -> m b
+ifJustM dft Nothing _  = return dft
+ifJustM _ (Just x) act = act x
+
+maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
+maybeM dft act mb = mb >>= maybe dft act
+
 maybeT :: Monad m => m a -> MaybeT m a -> m a
 maybeT x m = runMaybeT m >>= maybe x return
 
@@ -323,9 +330,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
 
 
 
------------
+------------
--- Maybe --
+-- Either --
------------
+------------
 
 maybeLeft  :: Either a b -> Maybe a
 maybeLeft  (Left a) = Just a

src/Utils/DB.hs

@@ -37,8 +37,11 @@ getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does
 
 existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
   => Unique record -> ReaderT backend m Bool
-existsBy = fmap isJust . getBy
+existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
 
+existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
+  => Key record -> ReaderT backend m Bool
+existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m