diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index dd2b2d0f4..5bedd38af 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/models b/models index 91261853e..a83eb4e9c 100644 --- a/models +++ b/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 diff --git a/routes b/routes index 9698bb8a5..393582a02 100644 --- a/routes +++ b/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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index ec0493e8f..bc7a639b7 100644 --- a/src/Auth/LDAP.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 7f25aa50b..bb7595fc7 100644 --- a/src/Foundation.hs +++ b/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 ] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index ad6e06bed..1999adb49 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 86bb8936f..8bf5aabe7 100644 --- a/src/Handler/Corrections.hs +++ b/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] - addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num + num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] + [ 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 - , SubmissionRatingComment =. Nothing - , SubmissionRatingBy =. Nothing - , SubmissionRatingTime =. Nothing - ] - addMessageI "success" $ MsgRemovedCorrections num + num <- updateWhereCount [SubmissionId <-. subs] + [ SubmissionRatingPoints =. Nothing + , SubmissionRatingComment =. Nothing + , SubmissionRatingBy =. Nothing + , SubmissionRatingAssigned =. Nothing + , 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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6dd5c277a..f5af4b949 100644 --- a/src/Handler/Course.hs +++ b/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 - | otherwise -> addMessageI "danger" MsgCourseSecretWrong + when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk + | 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 $ (,,) - <$> ireq ciTextField "csh" - <*> iopt textField "tid" - <*> iopt ciTextField "ssh" + params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button + <$> iopt termNewField "tid" + <*> 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 - tid <- ifMaybeM mbTid Nothing $ \tid -> - case termFromText tid of - Left err -> addMessage "error" (toHtml err) >> return Nothing - Right t -> return $ Just $ TermKey t - getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh + FormSuccess (mbTid,mbSsh,mbCsh) -> + getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh csh = do +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +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.&&. lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + 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]) - 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 cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh - when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse + <*> ifMaybeM mbCsh True (\csh -> (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 sshOk==True otherwise + unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh + 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 -courseDeleteHandler = undefined +getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2826e2c81..73aa370d2 100644 --- a/src/Handler/Home.hs +++ b/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") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 11a180cfb..d23328925 100644 --- a/src/Handler/Profile.hs +++ b/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 () diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6cc6daa2f..c9d244ae0 100644 --- a/src/Handler/Sheet.hs +++ b/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) - FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs + | otherwise -> loads'' <$ addMessageI Warning (MsgCorrectorExists email) + 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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cd8ce6cd4..39abc8e00 100644 --- a/src/Handler/Submission.hs +++ b/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 - , submissionRatingComment = Nothing - , submissionRatingBy = Nothing - , submissionRatingTime = Nothing + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = 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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 4247d8a71..1720eec1f 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ccedb3f71..0cd7de45c 100644 --- a/src/Handler/Users.hs +++ b/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 () diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1c02d4235..394359b27 100644 --- a/src/Handler/Utils.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ed570c134..6cfbe37bf 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 = selectFieldList [(unTermKey t, t)| t <- tids ] +termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName +-- 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 - 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 - +termNewField = checkMMap (return.termFromText) termToText textField schoolField :: Field Handler SchoolId schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index bd4f44daa..32b9e4d65 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 - submissionRatingPoints = Nothing - submissionRatingComment = Nothing - submissionRatingBy = Nothing - submissionRatingTime = Nothing + submissionSheet = sheetId + submissionRatingPoints = Nothing + submissionRatingComment = Nothing + submissionRatingBy = 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) $ diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c779842d6..3e017472c 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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' diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 7a37a93b7..17d4e091d 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index ce68f6a75..4869e236e 100644 --- a/src/Settings.hs +++ b/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) diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs new file mode 100644 index 000000000..438d21932 --- /dev/null +++ b/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)