diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 76b99261b..c1b8fcca7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -223,11 +223,14 @@ NoCorrector: Kein Korrektor RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt. CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: +SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt! + 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 b8ae4e76b..594b69fad 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 014a25e28..6116665dc 100644 --- a/routes +++ b/routes @@ -39,7 +39,7 @@ /info VersionR GET !free /profile ProfileR GET POST !free !free -/profile/data ProfileDataR GET !free !free +/profile/data ProfileDataR GET POST !free !free /term TermShowR GET !free /term/current TermCurrentR GET !free @@ -55,10 +55,15 @@ -- 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 /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !/ex/new SheetNewR GET POST @@ -77,10 +82,6 @@ /correctors SCorrR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector --- /user/#CryptoUUIDUser --- /users --- /correctors - /corrections CorrectionsR GET POST !corrector !lecturer /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 8cd985677..809db8647 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -52,7 +52,7 @@ dummyLogin = AuthPlugin{..} ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm case loginRes of FormFailure errs -> do - lift . forM_ errs $ addMessage "error" . toHtml + lift . forM_ errs $ addMessage Error . toHtml redirect LoginR FormMissing -> redirect LoginR FormSuccess ident -> diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 23b4ea647..32c185519 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -86,7 +86,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{ campusIdent = CI.original -> campusIdent, ..} -> do diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index a5a48699f..ba7198710 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -61,7 +61,7 @@ hashLogin pwHashAlgo = AuthPlugin{..} ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm case loginRes of FormFailure errs -> do - forM_ errs $ addMessage "error" . toHtml + forM_ errs $ addMessage Error . toHtml redirect LoginR FormMissing -> redirect LoginR FormSuccess HashLogin{..} -> do diff --git a/src/Foundation.hs b/src/Foundation.hs index 2c3040ec4..105c859ab 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -82,7 +82,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 @@ -311,7 +311,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 ) @@ -853,12 +853,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 @@ -880,12 +874,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 @@ -1151,7 +1157,7 @@ instance YesodAuth UniWorX where excHandlers | isDummy || isPWHash = [ 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 d0682f855..156961629 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -53,9 +53,9 @@ postAdminTestR :: Handler Html postAdminTestR = do ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of - (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" - (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt" - _other -> return () + (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" + (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" + _other -> addMessage Warning "KEIN Knopf erkannt" getAdminTestR @@ -66,6 +66,6 @@ getAdminUserR uuid = do defaultLayout $ [whamlet|

TODO -

Admin Page for User #{display userDisplayName} +

Admin Page for User ^{nameWidget userDisplayName userSurname} |] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d4692c59d..94aab5738 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -123,8 +123,13 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) -colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let - cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName) +colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let + csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 + link cid = CourseR tid ssh csh $ CUserR cid + cell = listCell (Map.toList users) $ \(userId, User{..}) -> do + anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) @@ -143,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 ) @@ -243,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 @@ -251,26 +266,38 @@ 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 + (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do + E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission + E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs + E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) + return (E.countRows :: E.SqlExpr (E.Value Int64)) + when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors 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' @@ -279,16 +306,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 @@ -341,7 +368,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 @@ -355,15 +384,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 @@ -376,13 +407,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 - , colCorrector + , colSMatrikel , colSubmittors , colSubmissionLink , colRating + , colRated + , colCorrector + , colAssigned ] psValidator = def correctionsR whereClause colonnade psValidator $ Map.fromList @@ -427,7 +461,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 @@ -436,23 +470,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 @@ -482,16 +518,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 fe2ae879e..47240a3ed 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 ciField "csh" - <*> iopt textField "tid" - <*> iopt ciField "ssh" + params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button + <$> iopt termNewField "tid" + <*> iopt ciField "ssh" + <*> iopt ciField "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 @@ -587,3 +593,24 @@ validateCourse (CourseForm{..}) = -- ) -- , ] ] + + + +getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCUsersR tid ssh csh = undefined -- TODO + + +getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html +getCUserR tid ssh csh uuid = do + uid <- decrypt uuid + User{..} <- runDB $ get404 uid + defaultLayout $ + [whamlet| +

TODO +

Lecturer's Page for User ^{nameWidget userDisplayName userSurname} + |] + +getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCHiWisR tid ssh csh = undefined -- TODO + + 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..29918fe82 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 () @@ -140,13 +140,21 @@ postProfileR = do -- TODO getProfileR - +postProfileDataR :: Handler Html +postProfileDataR = do + (uid, User{..}) <- requireAuthPair + ((btnResult,_), _) <- runFormPost $ buttonForm + case btnResult of + (FormSuccess BtnDelete) -> addMessage Warning "Delete-Knopf gedrückt" + (FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt" + _other -> addMessage Warning "KEIN Knopf erkannt" + addMessage Error "Löschen der Daten wurde noch nicht implementiert." + getProfileDataR getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair -- mr <- getMessageRender - -- Tabelle mit eigenen Kursen (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum @@ -163,6 +171,20 @@ getProfileDataR = do ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] -- Tabelle mit allen Tutorials tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|] + -- Delete Button + (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) + -- TODO: move this into a Message and/or Widget-File + let delWdgt = [whamlet| +
+
Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen? + Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht, + wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird. +
+ Gilt nicht in der Testphase von Uni2work: + Klausurnoten können Sie hiermit nicht löschen. + Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen. +
^{btnWdgt} + |] defaultLayout $ do $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index dee3173b1..67d119c10 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 44365751c..b64be4126 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 4d199720f..8208d1a1f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -120,5 +120,5 @@ postAdminHijackUserR cID = do get404 uid setCredsRedirect $ Creds "dummy" (CI.original 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 82fae9300..6236c1194 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -218,26 +218,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/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index e29d9e3f9..810ea8472 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -16,6 +16,15 @@ modalStatic modalContent = do $(widgetFile "widgets/modalStatic") [whamlet|
?|] -- SJ: confused why ## is needed here either? +modalWidget :: Html -> WidgetT site IO () -> WidgetT site IO () +modalWidget modalTrigger modalContent = do + uniqueId <- newIdent + let modalTriggerId = cons '#' uniqueId -- SJ: I am confused why this is needed here? + modalId :: Int32 + modalId = 13 + $(widgetFile "widgets/modalWidget") + [whamlet|
#{modalTrigger}|] -- SJ: confused why ## is needed here either? + modal :: Text -> Maybe [Char] -> WidgetT site IO () modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template! let diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 252e9f8ac..19d0bb34d 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import + , addMessage, addMessageI ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 47efdc4bb..4f406a148 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -295,7 +295,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 @@ -370,11 +370,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 @@ -399,6 +401,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 43a6834b2..4649c76f4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -33,7 +33,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.hs b/src/Utils.hs index 50a95d4b1..08343ec80 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -25,6 +25,8 @@ import Utils.DB as Utils import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils +import Utils.Message as Utils + import Text.Blaze (Markup, ToMarkup) 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) diff --git a/src/index.md b/src/index.md index eb0870ba4..a1c616b17 100644 --- a/src/index.md +++ b/src/index.md @@ -19,6 +19,9 @@ Utils.Form Utils.PathPiece : (Template-Haskell)-Hilfsfunktionen für Formulierung von PathPiece-Instanzen +Utils.Message + : redefines addMessage, addMessageI, defines MessageClass + Utils.Lens : Automatisch erzeugt Linsen für eigene und Yesod-Typen, `Control.Lens`-Export diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 6afe2d43d..ea27a3906 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -34,7 +34,7 @@

  • Modals: ^{modal ".toggler1" Nothing} - Klick mich für Ajax-Test + Klick mich für Ajax-Test ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
    Klick mich für Content-Test diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index afe2c4a6b..5b6726cf1 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -1,11 +1,4 @@
    -
    -
    -
    - TODO: Alle Benutzerbezogenen Daten sollen hier angezeigt - und verlinkt werden - (alle Abgaben, Klausurnoten, etc.) - $if hasRows

    Eigene Kurse @@ -58,8 +51,7 @@ .

    - TODO: Knopf zum Löschen aller Daten erstellen - + ^{modalWidget "Alle Benutzerbezogenen Daten löschen" delWdgt}

    Hinweise:
      diff --git a/templates/widgets/modalWidget.hamlet b/templates/widgets/modalWidget.hamlet new file mode 100644 index 000000000..e80516d1f --- /dev/null +++ b/templates/widgets/modalWidget.hamlet @@ -0,0 +1,2 @@ +
      + ^{modalContent}