Major contributions towards #189 and #194

messages/uniworx/de.msg

@@ -228,6 +228,7 @@ CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
 
 RatingBy: Korrigiert von
+AssignedTime: Zuteilung
 AchievedBonusPoints: Erreichte Bonuspunkte
 AchievedNormalPoints: Erreichte Punkte
 AchievedPassPoints: Erreichte Punkte

models

@@ -41,7 +41,7 @@ StudyTerms
     Primary key
 Term json
     name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
-    start         Day            -- TermKey   :: TermIdentifier -< TermId
+    start         Day            -- TermKey   :: TermIdentifier -> TermId
     end           Day
     holidays      [Day]
     lectureStart  Day 
@@ -136,6 +136,7 @@ Submission
     ratingPoints    Points  Maybe -- "Just" does not mean done
     ratingComment   Text    Maybe -- "Just" does not mean done
     ratingBy        UserId  Maybe -- assigned corrector
+    ratingAssigned  UTCTime Maybe -- time assigned corrector
     ratingTime      UTCTime Maybe -- "Just" here indicates done!
     deriving Show
 SubmissionEdit

routes

@@ -55,10 +55,12 @@
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
+!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand}   CourseNewTemplateR GET   !lecturer
 /course/#TermId/#SchoolId/#CourseShorthand CourseR          !lecturer:
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
+  /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET
   /user/#CryptoUUIDUser       CUserR          GET
   /correctors                 CHiWisR         GET

src/Auth/LDAP.hs

@@ -79,7 +79,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
       ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
       case loginRes of
         FormFailure errs -> do
-          forM_ errs $ addMessage "error" . toHtml
+          forM_ errs $ addMessage Error . toHtml
           redirect LoginR
         FormMissing -> redirect LoginR
         FormSuccess CampusLogin{..} -> do

src/Foundation.hs

@@ -81,7 +81,7 @@ import Utils
 import Utils.Form
 import Utils.Lens
 
-import Data.Aeson
+import Data.Aeson hiding (Error)
 import Data.Aeson.TH
 import qualified Data.Yaml as Yaml
 
@@ -308,7 +308,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
   [("free", trueAP)
   ,("deprecated", APHandler $ \r _ -> do
       $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
-      addMessageI "error" MsgDeprecatedRoute
+      addMessageI Error MsgDeprecatedRoute
       allow <- appAllowDeprecated . appSettings <$> getYesod
       return $ bool (Unauthorized "Deprecated Route") Authorized allow
     )
@@ -850,12 +850,6 @@ pageActions (CourseListR) =
   ]
 pageActions (CourseR tid ssh csh CShowR) =
   [ PageActionPrime $ MenuItem
-      { menuItemLabel = "Kurs Editieren"
-      , menuItemIcon  = Nothing
-      , menuItemRoute = CourseR tid ssh csh CEditR
-      , menuItemAccessCallback' = return True
-      }
-  , PageActionPrime $ MenuItem
       { menuItemLabel = "Übungsblätter"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetListR
@@ -877,12 +871,24 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemRoute = CourseR tid ssh csh CCorrectionsR
       , menuItemAccessCallback' = return True
       }
-  , PageActionSecondary $ MenuItem
+  , PageActionPrime $ MenuItem
       { menuItemLabel = "Neues Übungsblatt anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetNewR
       , menuItemAccessCallback' = return True
       }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Kurs editieren"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid ssh csh CEditR
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Neuen Kurs klonen"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CourseR tid ssh csh SheetListR) =
   [ PageActionPrime $ MenuItem
@@ -1152,7 +1158,7 @@ instance YesodAuth UniWorX where
         excHandlers
           | isDummy || isPWFile
           = [ C.Handler $ \err -> do
-                addMessage "error" (toHtml $ tshow (err :: CampusUserException))
+                addMessage Error (toHtml $ tshow (err :: CampusUserException))
                 $logErrorS "LDAP" $ tshow err
                 acceptExisting
             ]

src/Handler/Admin.hs

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

src/Handler/Corrections.hs

@@ -148,6 +148,16 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
   in anchorCellM mkRoute $(widgetFile "widgets/rating")
 
+colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+  maybe mempty timeCell submissionRatingAssigned
+
+colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+  maybe mempty timeCell submissionRatingTime
+
+
+
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
             
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
@@ -248,7 +258,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
 
   Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
   case actionRes of
-    FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
     FormMissing      -> return ()
     FormSuccess (CorrDownloadData, subs) -> do
       ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
@@ -256,26 +266,32 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       sendResponse =<< submissionMultiArchive ids
     FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
+      now <- liftIO getCurrentTime
       runDB $ do
         alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
-          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
+          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
-          addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
+                    [ SubmissionRatingBy       =. Just uid
+                    , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
+                    ]
+          addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
       redirect currentRoute
     FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
       runDB $ do
-        num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
+        num <- updateWhereCount [SubmissionId <-. subs]
-                                                        , SubmissionRatingComment =. Nothing
+                  [ SubmissionRatingPoints   =. Nothing
-                                                        , SubmissionRatingBy =. Nothing
+                  , SubmissionRatingComment  =. Nothing
-                                                        , SubmissionRatingTime =. Nothing
+                  , SubmissionRatingBy       =. Nothing
-                                                        ]
+                  , SubmissionRatingAssigned =. Nothing
-        addMessageI "success" $ MsgRemovedCorrections num
+                  , SubmissionRatingTime     =. Nothing
+                  ]
+        addMessageI Success $ MsgRemovedCorrections num
       redirect currentRoute
     FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
@@ -284,16 +300,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
           (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
           when (not $ null assigned) $
-            addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
+            addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
           when (not $ null unassigned) $ do
             mr <- (toHtml . ) <$> getMessageRender
             unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) 
-            addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
+            addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
   fmap toTypedContent . defaultLayout $ do
@@ -346,7 +362,9 @@ postCorrectionsR = do
         , colCourse
         , colSheet
         , colSubmissionLink
+        , colAssigned
         , colRating
+        , colRated
         ] -- Continue here
       psValidator = def
         & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
@@ -360,15 +378,17 @@ getCCorrectionsR = postCCorrectionsR
 postCCorrectionsR tid ssh csh = do
   Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
   let whereClause = courseIs cid
-      colonnade = mconcat
+      colonnade = mconcat -- should match getSSubsR for consistent UX
         [ colSelect
         , dbRow
         , colSheet
-        , colCorrector
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
         , colRating
+        , colRated
+        , colCorrector
+        , colAssigned
         ] -- Continue here
       psValidator = def
   correctionsR whereClause colonnade psValidator $ Map.fromList
@@ -381,14 +401,16 @@ getSSubsR = postSSubsR
 postSSubsR tid ssh csh shn = do
   shid <- runDB $ fetchSheetId tid ssh csh shn
   let whereClause = sheetIs shid
-      colonnade = mconcat
+      colonnade = mconcat -- should match getCCorrectionsR for consistent UX
         [ colSelect
         , dbRow
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
         , colRating
+        , colRated
         , colCorrector
+        , colAssigned
         ]
       psValidator = def
   correctionsR whereClause colonnade psValidator $ Map.fromList
@@ -433,7 +455,7 @@ postCorrectionR tid ssh csh shn cid = do
 
       case corrResult of
         FormMissing -> return ()
-        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess (ratingPoints, ratingComment) -> do
           runDB $ do
             uid <- liftHandlerT requireAuthId
@@ -442,23 +464,25 @@ postCorrectionR tid ssh csh shn cid = do
             let rated = isJust $ void ratingPoints <|> void ratingComment
           
             update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
+-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
+--                        , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
                        , SubmissionRatingTime    =. (now <$ guard rated)
                        , SubmissionRatingPoints  =. ratingPoints
                        , SubmissionRatingComment =. ratingComment
                        ]
 
-            addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
+            addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
         FormMissing -> return ()
-        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
           runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
-          addMessageI "success" MsgRatingFilesUpdated
+          addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       defaultLayout $ do
@@ -488,16 +512,16 @@ postCorrectionsUploadR = do
 
   case uploadRes of
     FormMissing -> return ()
-    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
       subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
       if
-        | null subs -> addMessageI "warning" MsgNoCorrectionsUploaded
+        | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do
             subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
             mr <- (toHtml .) <$> getMessageRender
-            addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+            addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
         
 
   defaultLayout $ do

src/Handler/Course.hs

@@ -304,51 +304,52 @@ postCRegisterR tid ssh csh = do
     (FormSuccess codeOk)
       | registered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
-          addMessageI "info" MsgCourseDeregisterOk
+          addMessageI Info MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
-          when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
+          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
-      | otherwise -> addMessageI "danger" MsgCourseSecretWrong
+      | otherwise -> addMessageI Warning MsgCourseSecretWrong
     (_other) -> return () -- TODO check this!
   redirect $ CourseR tid ssh csh CShowR
 
-getCourseNewR :: Handler Html
+getCourseNewR :: Handler Html -- call via toTextUrl
 getCourseNewR = do
   uid <- requireAuthId
-  params <- runInputGetResult $ (,,)
+  params <- runInputGetResult $ (,,)    --TODO: change to AForm, which is used in Course-Copy-Button
-            <$> ireq ciTextField "csh"
+            <$> iopt termNewField "tid"
-            <*> iopt   textField "tid"
+            <*> iopt ciTextField  "ssh"
-            <*> iopt ciTextField "ssh"
+            <*> iopt ciTextField  "csh"
   let noTemplateAction = courseEditHandler True Nothing
   case params of
     FormMissing      -> noTemplateAction
-    FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
+    FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml)
                         >> noTemplateAction
-    FormSuccess (csh,mbTid,mbSsh) -> do
+    FormSuccess (mbTid,mbSsh,mbCsh) ->
-      tid <- ifMaybeM mbTid Nothing $ \tid ->
+      getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
-        case termFromText tid of
-          Left err -> addMessage "error" (toHtml err) >> return Nothing
-          Right t  -> return $ Just $ TermKey t
-      getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh
 
-getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html
+getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
-getCourseNewTemplateR mbTid mbSsh csh = do
+getCourseNewTemplateR mbTid mbSsh mbCsh = do
   uid <- requireAuthId
   oldCourses <- runDB $ do
     E.select $ E.from $ \course -> do
-      E.where_                            $ course E.^. CourseShorthand  E.==. E.val csh
-      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
       whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
-      let lecturersSchool =
+      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+      whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
+      let lecturersCourse =
             E.exists $ E.from $ \lecturer -> do
-              E.where_ $ lecturer E.^. UserLecturerUser   E.==. E.val uid
+              E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
-                  E.&&.  lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+                  E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      let lecturersSchool =
+            E.exists $ E.from $ \user -> do
+              E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                  E.&&.  user 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 from schools of lecturer
+      E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
+                , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
                 , E.desc $ courseCreated course]                                     -- most recent created course
       E.limit 1
       return course
@@ -366,11 +367,11 @@ getCourseNewTemplateR mbTid mbSsh csh = do
         (tidOk,sshOk,cshOk) <- runDB $ (,,)
             <$> ifMaybeM mbTid True existsKey
             <*> ifMaybeM mbSsh True existsKey
-            <*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+            <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
-        unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+        unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
-        unless sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+        unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
-        unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
+        unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
-        when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
+        when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
         return Nothing
   courseEditHandler True template
 
@@ -389,14 +390,16 @@ pgCEditR isGetReq tid ssh csh = do
   courseEditHandler isGetReq $ courseToForm <$> course
 
 
-courseDeleteHandler :: Handler Html -- not called anywhere yet
+getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-courseDeleteHandler = undefined
+getCDeleteR = error "TODO: implement getCDeleteR"
+postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+postCDeleteR = error "TODO: implement getCDeleteR"
 {- TODO
         | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
         , Just cid <- cfCourseId res -> do
             runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
             let cti = toPathPiece $ cfTerm res
-            addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
+            addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
             redirect $ TermCourseListR $ cfTerm res
 -}
 
@@ -435,10 +438,10 @@ courseEditHandler isGet mbCourseForm = do
               runDB $ do
                 insert_ $ CourseEdit aid now cid
                 insert_ $ Lecturer aid cid
-              addMessageI "info" $ MsgCourseNewOk tid ssh csh
+              addMessageI Info $ MsgCourseNewOk tid ssh csh
               redirect $ TermCourseListR tid
             Nothing ->
-              addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
+              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
 
       (FormSuccess res@(
         CourseForm  { cfCourseId = Just cid
@@ -451,7 +454,7 @@ courseEditHandler isGet mbCourseForm = do
           success <- runDB $ do
             old <- get cid
             case old of
-              Nothing -> addMessageI "error" MsgInvalidInput $> False
+              Nothing -> addMessageI Error MsgInvalidInput $> False
               (Just oldCourse) -> do
                 updOkay <- myReplaceUnique cid (  -- replaceUnique requires Eq Course, which we cannot have
                     Course  {  courseName            = cfName       res
@@ -469,14 +472,14 @@ courseEditHandler isGet mbCourseForm = do
                     }
                   )
                 case updOkay of
-                  (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
+                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     insert_ $ CourseEdit aid now cid
-                    addMessageI "success" $ MsgCourseEditOk tid ssh csh
+                    addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
 
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
       (FormMissing) -> return ()
     actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
     defaultLayout $ do
@@ -526,6 +529,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do
         , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
         ]
     let termsField = case template of
+          --TODO: if Admin, then all
+          -- if allowed to delete course then allow current and all active term
+          -- otherwise only keep current term
           (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
           _allOtherCases -> termsActiveField
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm

src/Handler/Home.hs

@@ -107,7 +107,7 @@ homeAnonymous = do
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
   let features = $(widgetFile "featureList")
-  addMessage "danger" "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout $ do
     $(widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
@@ -207,7 +207,7 @@ homeUser uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  addMessage "danger" "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
   defaultLayout $ do
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")

src/Handler/Profile.hs

@@ -87,10 +87,10 @@ getProfileR = do
                                       , OffsetBy $ stgMaxFavourties
                                       ]
             mapM_ delete oldFavs
-        addMessageI "info" $ MsgSettingsUpdate
+        addMessageI Info $ MsgSettingsUpdate
         redirect ProfileR -- TODO: them change does not happen without redirect
 
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
     _ -> return ()
 
 

src/Handler/Sheet.hs

@@ -305,7 +305,7 @@ getSShowR tid ssh csh shn = do
     return (hasHints, hasSolution)
   cTime <- Just <$> liftIO getCurrentTime
   visibleFrom <-    traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom  sheet
-  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
+  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
     maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
   defaultLayout $ do
     setTitleI $ MsgSheetTitle tid ssh csh shn
@@ -444,21 +444,21 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               }
         mbsid <- dbAction newSheet
         case mbsid of
-          Nothing    -> False <$ addMessageI "error" (MsgSheetNameDup tid ssh csh sfName)
+          Nothing    -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
           (Just sid) ->  do -- save files in DB:
             whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
             whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
             whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
             whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
             insert_ $ SheetEdit aid actTime sid
-            addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
+            addMessageI Info $ MsgSheetEditOk tid ssh csh sfName
             -- Sanity checks generating warnings only, but not errors!
             warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
             return True
       when saveOkay $ redirect $ case msId of
         Just _  -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
         Nothing -> CSheetR tid ssh csh sfName SCorrR
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
     _ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
           <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
 
@@ -481,7 +481,7 @@ getSDelR tid ssh csh shn = do
     (FormSuccess BtnDelete) -> do
       runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
       -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-      addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
+      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
       redirect $ CourseR tid ssh csh SheetListR
     _other -> do
       submissionno <- runDB $ do
@@ -572,7 +572,7 @@ correctorForm shid = do
   (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
   loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
-    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
+    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
     | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
 
   deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
@@ -608,11 +608,11 @@ correctorForm shid = do
     FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
       mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
       case mUid of
-        Nothing  -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
+        Nothing  -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
         Just uid
           | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
-          | otherwise                   -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
+          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
-    FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
     _ -> return loads''
 
   let deletions' = deletions `Set.difference` Map.keysSet loads
@@ -703,11 +703,11 @@ getSCorrR tid ssh csh shn = do
   ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
 
   case res of
-    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess res -> runDB $ do
       deleteWhere [SheetCorrectorSheet ==. shid]
       insertMany_ $ Set.toList res
-      addMessageI "success" MsgCorrectorsUpdated
+      addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 
   let

src/Handler/Submission.hs

@@ -147,7 +147,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             return (csheet, map E.unValue buddies, [])
           (E.Value smid:_) -> do
             cID <- encrypt smid
-            addMessageI "info" $ MsgSubmissionAlreadyExists
+            addMessageI Info $ MsgSubmissionAlreadyExists
             redirect $ CSubmissionR tid ssh csh shn cID SubShowR
       (Just smid) -> do
         void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
@@ -237,10 +237,11 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             (Nothing, Nothing) -- new submission, no file upload requested
               -> insert Submission
                   { submissionSheet = shid
-                  , submissionRatingPoints = Nothing
+                  , submissionRatingPoints   = Nothing
-                  , submissionRatingComment = Nothing
+                  , submissionRatingComment  = Nothing
-                  , submissionRatingBy = Nothing
+                  , submissionRatingBy       = Nothing
-                  , submissionRatingTime = Nothing
+                  , submissionRatingAssigned = Nothing
+                  , submissionRatingTime     = Nothing
                   }
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
@@ -258,7 +259,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           return smid
         cID <- encrypt smid
         return $ Just cID
-      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
+      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
       _other -> return Nothing
   
   case mCID of

src/Handler/Term.hs

@@ -167,12 +167,12 @@ termEditHandler term = do
 -- VOR INTERNATIONALISIERUNG:
 --           let tid = termToText $ termName res
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
---           addMessage "success" [shamlet| #{msg} |]
+--           addMessage Success [shamlet| #{msg} |]
 -- MIT INTERNATIONALISIERUNG:
-          addMessageI "success" $ MsgTermEdited tid
+          addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       (FormMissing  ) -> return ()
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
     let actionUrl   = TermEditR
     defaultLayout $ do
       setTitleI MsgTermEditHeading

src/Handler/Users.hs

@@ -118,5 +118,5 @@ postAdminHijackUserR cID = do
             get404 uid
           setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
       | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
-    FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
     FormMissing -> return $ toTypedContent ()

src/Handler/Utils.hs

@@ -68,7 +68,7 @@ warnTermDays tid times = do
       outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
       outoflecture  = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
                         `Set.difference` outoftermdays -- out of term implies out of lecture-time
-      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
+      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
   forM_ warnholidays  $ warnI MsgDayIsAHoliday
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm

src/Handler/Utils/Form.hs

@@ -222,26 +222,17 @@ termsActiveField :: Field Handler TermId
 termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
 termsSetField :: [TermId] -> Field Handler TermId
--- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
+termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
-termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
+-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
 
+termsActiveOrSetField :: [TermId] -> Field Handler TermId
+termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
+  where terms = map unTermKey tids
 -- termActiveOld :: Field Handler TermIdentifier
 -- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
 termNewField :: Field Handler TermIdentifier
-termNewField = checkMMap checkTerm termToText textField
+termNewField = checkMMap (return.termFromText) termToText textField
-  where
-    errTextParse :: Text
-    errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
-
-    errTextFreigabe :: TermIdentifier -> Text
-    errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
-
-    checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
-    checkTerm t = case termFromText t of
-      Left  _       -> return $ Left errTextParse
-      res@(Right _) -> return res
-
 
 schoolField :: Field Handler SchoolId
 schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName

src/Handler/Utils/Submission.hs

@@ -210,7 +210,10 @@ assignSubmissions sid restriction = do
               $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
               assignSubmission (countsToLoad' q) smid q
 
-    forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
+    now <- liftIO getCurrentTime
+    forM_ (Map.toList subTutor) $
+        \(smid, tutid) -> update smid [ SubmissionRatingBy       =. Just tutid
+                                      , SubmissionRatingAssigned =. Just now  ]
         
     let assignedSubmissions   = Map.keysSet subTutor
         unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
@@ -325,7 +328,7 @@ extractRatingsMsg = do
       ignored = Right `Set.map` ignored'
   unless (null ignored) $ do
     mr <- (toHtml . ) <$> getMessageRender
-    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
@@ -343,11 +346,13 @@ sinkSubmission userId mExists isUpdate = do
   sId <- lift $ case mExists of
     Left sheetId -> do
       let
-        submissionSheet         = sheetId
+        submissionSheet          = sheetId
-        submissionRatingPoints  = Nothing
+        submissionRatingPoints   = Nothing
-        submissionRatingComment = Nothing
+        submissionRatingComment  = Nothing
-        submissionRatingBy      = Nothing
+        submissionRatingBy       = Nothing
-        submissionRatingTime    = Nothing
+        submissionRatingAssigned = Nothing
+        submissionRatingTime     = Nothing
+
       sId <- insert Submission{..}
       -- now <- liftIO getCurrentTime
       -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
@@ -466,6 +471,7 @@ sinkSubmission userId mExists isUpdate = do
             lift $ case isUpdate of
               False -> insert_ $ SubmissionEdit userId now submissionId
               True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                        -- TODO: Should submissionRatingAssigned change here if userId changes?
             tell $ mempty{ sinkSubmissionTouched = Any True }
 
         finalize :: SubmissionSinkState -> YesodDB UniWorX ()
@@ -586,7 +592,7 @@ sinkMultiSubmission userId isUpdate = do
             lift . feed sId $ Left f{ fileTitle = fileTitle' }
   when (not $ null ignored) $ do
     mr <- (toHtml .) <$> getMessageRender
-    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
   fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
     cID <- encrypt sId
     handle (throwM . SubmissionSinkException cID Nothing) $

src/Handler/Utils/Table/Pagination.hs

@@ -402,7 +402,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
       <* E.offset (psPage * psLimit)
       <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
 
-  mapM_ (addMessageI "warning") errs
+  mapM_ (addMessageI Warning) errs
 
   runDB $ do
     rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'

src/Model/Types.hs

@@ -293,7 +293,7 @@ termFromText t
   , Just (review shortened -> year) <- readMaybe ys
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
-  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
+  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
 
 termToRational :: TermIdentifier -> Rational
 termToRational TermIdentifier{..} = fromInteger year + seasonOffset
@@ -368,11 +368,13 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Theme"
   } ''Theme
 
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
 instance Universe Theme where universe = universeDef
 instance Finite Theme
 
 instance PathPiece Theme where
-  toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  toPathPiece   = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
   fromPathPiece = finiteFromPathPiece
 
 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
@@ -397,6 +399,8 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
 deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Corrector"
   } ''CorrectorState

src/Settings.hs

@@ -31,7 +31,7 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
-import Utils
+import Utils hiding (MessageClass(..))
 import Control.Lens
 
 import Data.Maybe (fromJust)

src/Utils/Message.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+
+module Utils.Message
+  ( MessageClass(..)
+  , addMessage, addMessageI
+  ) where
+
+
+import Data.Text as Text (toLower)
+import Data.Universe
+import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
+
+import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
+import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
+
+
+data MessageClass = Error | Warning | Info | Success
+  deriving (Eq,Ord,Enum,Bounded,Show,Read)
+
+instance Universe MessageClass
+instance Finite   MessageClass
+
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
+instance PathPiece MessageClass where
+  toPathPiece   = $(nullaryToPathPiece ''MessageClass [Text.toLower])
+  fromPathPiece = finiteFromPathPiece
+
+addMessage :: MonadHandler m => MessageClass-> Html -> m ()
+addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)
+
+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
+addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)