From 8633a05623d29ecc001ae9993f0a71079435b90a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Apr 2021 12:07:37 +0200 Subject: [PATCH 01/39] chore: update faq campus-cant-login --- .../faq/campus-cant-login.de-de-formal.hamlet | 60 +++++++++++++++---- .../i18n/faq/campus-cant-login.en-eu.hamlet | 55 ++++++++++++++--- 2 files changed, 93 insertions(+), 22 deletions(-) diff --git a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet index 17d7e6768..6b1d920e5 100644 --- a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet +++ b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet @@ -4,32 +4,66 @@ $newline never Können sie sich mit exakt identischen (idealerweise # copy&paste) Daten # im Campus-Portal # - anmelden?
+ anmelden? - Falls nicht, ist davon auszugehen, dass Sie Ihre Anmeldedaten falsch # - eingeben oder keine # - LMU-Benutzerkennung (ehem. Campus-Kennung) besitzen. +
+ + Falls nicht („_{MsgInvalidLogin}“), ist davon auszugehen, dass Sie # + Ihre Anmeldedaten falsch eingeben oder # + keine LMU-Benutzerkennung # + (ehem. Campus-Kennung) besitzen.

Beachten Sie dabei auch, dass Uni2work Leerzeichen sowohl im # - Passwort als auch bei der Kennung berücksichtigt.
+ Passwort als auch bei der Kennung berücksichtigt. + +
Beim Passwort ist zudem Groß- und Kleinschreibung relevant. +
+ + Prüfen Sie bitte (auch wenn Sie einen Passwortmanager verwenden) mit # + dem Auge-Symbol rechts neben dem Passwort-Feld (nur verfügbar mit # + aktiviertem JavaScript), dass Sie Ihr Passwort korrekt eingeben. +

Uni2work bietet zwei Login-Formulare. +
+ Für die Anmeldung mit der LMU-Benutzerkennung (ehem. Campus-Kennung) # - müssen Sie das Formular „Campus-Login“ verwenden. + müssen Sie das Formular „_{MsgLDAPLoginTitle}“ verwenden. +
- Geben Sie unter „Campus-Kennung“ ihre vollständige # - LMU-Benutzerkennung an. + + Geben Sie unter „_{MsgCampusIdent}“ ihre vollständige # + LMU-Benutzerkennung an. # + Diese ist identisch mit ihrer @campus.lmu.de E-Mail # Adresse.

- Falls Sie sich # - im Campus-Portal # - anmelden können, aber nicht in Uni2work, wenden Sie sich bitte über # - das Hilfe-Formular, oben rechts auf jeder # - Seite, an die Uni2work-Administration. + Falls Sie seit Ihrem letzten Login in Uni2work ihr Passwort geändert # + haben, kann es sein, dass die Änderung des Passworts (noch) nicht # + korrekt propagiert wurde. + +
+ + In diesem Fall können Sie versuchen Ihr Passwort erneut zu ändern. + +

+ Sobald Sie die obigen Hinweise befolgt haben, wenden Sie sich bitte # + (erneut) über das Hilfe-Formular, oben rechts # + auf jeder Seite, an die Uni2work-Administration. + +
+ + Erwähnen Sie dabei bitte, dass Sie die in diesem FAQ-Punkt # + aufgeführten Hinweise beachtet haben und schildern Sie, welche # + Schritte Sie bereits ergriffen haben. + +
+ + Teilen Sie Ihr Passwort niemals mit Dritten (auch nicht der # + Uni2work-Administration oder dem IT-Servicedesk der LMU)! diff --git a/templates/i18n/faq/campus-cant-login.en-eu.hamlet b/templates/i18n/faq/campus-cant-login.en-eu.hamlet index 67c2fe89e..6391ecd4a 100644 --- a/templates/i18n/faq/campus-cant-login.en-eu.hamlet +++ b/templates/i18n/faq/campus-cant-login.en-eu.hamlet @@ -4,31 +4,68 @@ $newline never Can you log in to # the Campus-Portal # using the exact same (ideally copied & pasted) login data? +
- If you cannot (“Invalid Login”), this means that you are entering # - your login data wrong or that you # + If you cannot (“_{MsgInvalidLogin}”), this means that you are # + entering your login data wrong or that you # do not have a LMU user ID # (formerly Campus-ID).

Please consider that for Uni2work both your user ID and password are # sensitive to whitespace characters. +
+ Your password is also case-sensitive. +
+ + Please also use the eye-symbol next to the password field to check # + that you have entered your password correctly. # + + The eye-symbol is only visible if JavaScript is activated in your # + browser. # + + Please check your password in this way, even if you are using a # + password manager instead of typing it manually. +

Uni2work offers two login forms. +
+ To log in using your LMU user ID (formerly Campus-ID) you need to # - use the form titled “Campus login”. + use the form titled “_{MsgLDAPLoginTitle}”. +
- Under “Campus account” please enter either your entire LMU user ID, # - which is identical to your @campus.lmu.de email address. + + Under “_{MsgCampusIdent}” please enter either your entire LMU user # + ID, which is identical to your @campus.lmu.de email # + address.

- If you can log in to # - the Campus-Portal # - but can't log in to Uni2work, please contact a # - Uni2work-Administrator using the Support form # + If you have changed your password since last you logged into # + Uni2work, it may be the case that your password change was not # + propagated properly. + +
+ + If so, please try changing your password again. + +

+ Once you have followed the suggestions above, please contact a # + Uni2work-administrator using the Support form # (at the top right of every page). + +
+ + Please include that you have read this faq-entry and which steps you # + have already taken. + +
+ + Never disclose your password to third parties! # + + Not even to an Uni2work-administrator or the IT-Servicedesk! From 5c709f1bbb077d981fbd5d59e9c0f30cddbb468d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Apr 2021 12:18:12 +0200 Subject: [PATCH 02/39] fix: build --- frontend/src/app.sass | 2 +- src/Handler/Info.hs | 5 ++++- templates/i18n/faq/campus-cant-login.de-de-formal.hamlet | 2 +- templates/i18n/faq/campus-cant-login.en-eu.hamlet | 6 +++--- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 2de117489..6ec0a287f 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -165,7 +165,7 @@ h4 margin-top: var(--current-header-height) margin-left: 0 - :target:not(table :target)::before + :target:not(table, .show-hide__toggle)::before content: "" display: block height: var(--current-header-height) diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 1153f81f3..a1ea696b2 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -14,7 +14,10 @@ import qualified Database.Esqueleto.Utils as E import Development.GitRev -import Auth.LDAP (ADError(..), ADInvalidCredentials(..)) +import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..)) + +import Yesod.Auth.Message(AuthMessage(..)) + -- | Versionsgeschichte getVersionR :: Handler TypedContent diff --git a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet index 6b1d920e5..9ee438b02 100644 --- a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet +++ b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet @@ -8,7 +8,7 @@ $newline never
- Falls nicht („_{MsgInvalidLogin}“), ist davon auszugehen, dass Sie # + Falls nicht („_{InvalidLogin}“), ist davon auszugehen, dass Sie # Ihre Anmeldedaten falsch eingeben oder # keine LMU-Benutzerkennung # (ehem. Campus-Kennung) besitzen. diff --git a/templates/i18n/faq/campus-cant-login.en-eu.hamlet b/templates/i18n/faq/campus-cant-login.en-eu.hamlet index 6391ecd4a..98a167538 100644 --- a/templates/i18n/faq/campus-cant-login.en-eu.hamlet +++ b/templates/i18n/faq/campus-cant-login.en-eu.hamlet @@ -7,7 +7,7 @@ $newline never
- If you cannot (“_{MsgInvalidLogin}”), this means that you are # + If you cannot (“_{InvalidLogin}”), this means that you are # entering your login data wrong or that you # do not have a LMU user ID # (formerly Campus-ID). @@ -41,8 +41,8 @@ $newline never
- Under “_{MsgCampusIdent}” please enter either your entire LMU user # - ID, which is identical to your @campus.lmu.de email # + Under “_{MsgCampusIdent}” please enter your entire LMU user ID, # + which is identical to your @campus.lmu.de email # address.

From 9859c2e99c1e0c7531ee38864a24ff279a8e6a7c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Apr 2021 14:51:31 +0200 Subject: [PATCH 03/39] fix: prevent deleting sheet-referenced exam parts Fixes #681 --- .hlint.yaml | 5 ++ messages/uniworx/misc/de-de-formal.msg | 3 +- messages/uniworx/misc/en-eu.msg | 3 +- src/Database/Esqueleto/Utils.hs | 14 +++++ src/Handler/Exam/Edit.hs | 86 ++++++++++++++++++-------- src/Handler/Exam/New.hs | 2 +- src/Utils/Sql.hs | 4 ++ 7 files changed, 87 insertions(+), 30 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index f6a6cd81c..24e2d327e 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -194,3 +194,8 @@ - warn: { lhs: n >= length xs, rhs: maxLength n xs, note: IncreasesLaziness } - warn: { lhs: length xs < n, rhs: maxLength (n - 1) xs, note: IncreasesLaziness } - warn: { lhs: n > length xs, rhs: maxLength (n - 1) xs, note: IncreasesLaziness } + + - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing} + - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing} + - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.nothing, rhs: Database.Esqueleto.Utils.isJust v, name: Use Esqueleto's not isNothing} + - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.Utils.isJust v, name: Use Esqueleto's not isNothing} diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index c3a4f176a..5744e0781 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -2018,9 +2018,10 @@ ExamPartSheets: Übungsblätter ExamPartsFrom: Teile anzeigen ab ExamPartsFromTip: Ab dem gegebenen Zeitpunkt wird die Liste von Prüfungsteilen/Aufgaben veröffentlicht, nicht jedoch die jeweilige Maximalpunktzahl. Ohne Zeitpunkt wird die Liste ab "Ergebnisse sichtbar ab" angezeigt. -ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam} +ExamEditExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam} ExamCreated exam@ExamName: #{exam} erfolgreich angelegt ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet +ExamEditWouldBreakSheetTypeReference: Durch Ihre Änderungen würde ein Prüfungsteil gelöscht, auf den durch ein Übungsblatt noch eine Referenz besteht. ExamNoShow: Nicht erschienen ExamVoided: Entwertet diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index f8e1ddff3..cdbf8e2f2 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -2017,9 +2017,10 @@ ExamPartSheets: Exercise sheets ExamPartsFrom: Parts visible from ExamPartsFromTip: At this time the list of exam parts/questions will be published, but without their respective maximum number of points. If left empty the list will be published with “Results visible from” -ExamNameTaken exam: There already is an exam named #{exam} +ExamEditExamNameTaken exam: There already is an exam named #{exam} ExamCreated exam: Successfully created #{exam} ExamEdited exam: Successfully edited #{exam} +ExamEditWouldBreakSheetTypeReference: Your changes include deleting an exam part to which a reference still exists through an exercise sheet. ExamNoShow: Not present ExamVoided: Voided diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a17b30cf1..cab53a24c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -32,6 +32,7 @@ module Database.Esqueleto.Utils , selectMaybe , day, diffDays, diffTimes , exprLift + , explicitUnsafeCoerceSqlExprValue , module Database.Esqueleto.Utils.TH ) where @@ -55,6 +56,8 @@ import Data.Coerce (Coercible) import Data.Time.Clock (NominalDiffTime) +import qualified Data.Text.Lazy.Builder as Text.Builder + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -130,6 +133,17 @@ substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3) ) substring a b c = substring (construct a) (construct b) (construct c) +explicitUnsafeCoerceSqlExprValue :: forall b a. + Text + -> E.SqlExpr (E.Value a) + -> E.SqlExpr (E.Value b) +explicitUnsafeCoerceSqlExprValue typ (E.ERaw p1 f1) = E.ERaw E.Parens $ \info -> + let (valTLB, valVals) = f1 info + in ( E.parensM p1 valTLB <> " :: " <> Text.Builder.fromText typ + , valVals + ) +explicitUnsafeCoerceSqlExprValue typ val = explicitUnsafeCoerceSqlExprValue typ $ construct val + construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> let (b1, vals) = f info diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 959b38580..909e571f7 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -14,6 +14,18 @@ import Handler.Utils.Invitations import Jobs.Queue +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +data ExamEditException + = ExamEditExamNameTaken ExamName + | ExamEditWouldBreakSheetTypeReference + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + +embedRenderMessage ''UniWorX ''ExamEditException id + getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEEditR = postEEditR @@ -27,31 +39,34 @@ postEEditR tid ssh csh examn = do ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do - insertRes <- myReplaceUnique eId Exam - { examCourse = cid - , examName = efName - , examGradingRule = efGradingRule - , examBonusRule = efBonusRule - , examOccurrenceRule = efOccurrenceRule - , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam - , examVisibleFrom = efVisibleFrom - , examRegisterFrom = efRegisterFrom - , examRegisterTo = efRegisterTo - , examDeregisterUntil = efDeregisterUntil - , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments - , examStart = efStart - , examEnd = efEnd - , examFinished = efFinished - , examClosed = examClosed oldExam - , examPublicStatistics = efPublicStatistics - , examGradingMode = efGradingMode - , examDescription = efDescription - , examExamMode = efExamMode - , examStaff = efStaff - , examPartsFrom = efPartsFrom - } + res <- trySql @ExamEditException $ do + insertRes <- myReplaceUnique eId Exam + { examCourse = cid + , examName = efName + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = examClosed oldExam + , examPublicStatistics = efPublicStatistics + , examGradingMode = efGradingMode + , examDescription = efDescription + , examExamMode = efExamMode + , examStaff = efStaff + , examPartsFrom = efPartsFrom + } + + when (is _Just insertRes) $ + throwM $ ExamEditExamNameTaken efName - when (is _Nothing insertRes) $ do occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ] forM_ (Set.toList efOccurrences) $ \case @@ -83,6 +98,21 @@ postEEditR tid ssh csh examn = do } pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId + + brokenRefs <- E.selectExists . E.from $ \examPart -> do + E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId + E.&&. examPart E.^. ExamPartId `E.notIn` E.valList pIds + E.where_ . E.exists . E.from $ \sheet -> do + let + sheetTypeExamPart :: E.SqlExpr (E.Value (Maybe Value)) + sheetTypeExamPart = sheet E.^. SheetType E.->. "exam-part" + examPartId' :: E.SqlExpr (E.Value Value) + examPartId' = E.explicitUnsafeCoerceSqlExprValue @Value "jsonb" . E.explicitUnsafeCoerceSqlExprValue @Text "text" $ examPart E.^. ExamPartId + E.where_ $ E.maybe E.false (E.==. examPartId') sheetTypeExamPart + + when brokenRefs $ + throwM ExamEditWouldBreakSheetTypeReference + deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] forM_ (Set.toList efExamParts) $ \case ExamPartForm{ epfId = Nothing, .. } -> insert_ @@ -118,9 +148,11 @@ postEEditR tid ssh csh examn = do deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites - return . Just $ case insertRes of - Just _ -> addMessageI Error $ MsgExamNameTaken efName - Nothing -> do + return insertRes + + return . Just $ case res of + Left exc -> addMessageI Error exc + Right _ -> do addMessageI Success $ MsgExamEdited efName redirect $ CExamR tid ssh csh efName EShowR diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 90d80c17d..4c20fe692 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -98,7 +98,7 @@ postCExamNewR tid ssh csh = do runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow return . Just $ case insertRes of - Nothing -> addMessageI Error $ MsgExamNameTaken efName + Nothing -> addMessageI Error $ MsgExamEditExamNameTaken efName Just _ -> do addMessageI Success $ MsgExamCreated efName redirect $ CourseR tid ssh csh CExamListR diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index dfc09d8ac..b00dcb87d 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -5,6 +5,7 @@ module Utils.Sql , catchSql, handleSql , isUniqueConstraintViolation , catchIfSql, handleIfSql + , trySql ) where import ClassyPrelude.Yesod hiding (handle) @@ -125,5 +126,8 @@ catchIfSql p = flip $ handleIfSql p handleIfSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => (e -> Bool) -> (e -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a handleIfSql p recover = handleSql (\err -> bool throwM recover (p err) err) +trySql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => SqlPersistT m a -> SqlPersistT m (Either e a) +trySql = handleSql (return . Left) . fmap Right + isUniqueConstraintViolation :: SqlError -> Bool isUniqueConstraintViolation SqlError{..} = "duplicate key value violates unique constraint" `ByteString.isPrefixOf` sqlErrorMsg From 6b9c0849e4af5a67b5b77e8ca5bbf3e419aeb8c1 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 29 Mar 2021 18:00:30 +0200 Subject: [PATCH 04/39] chore: show some Icon calling postCFavouriteR --- src/Foundation/Yesod/Middleware.hs | 3 ++ src/Handler/Course.hs | 1 + src/Handler/Course/Show.hs | 62 ++++++++++++++++++++++++++++++ src/Utils/Form.hs | 1 + src/Utils/Icon.hs | 5 +++ 5 files changed, 72 insertions(+) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3aa73ab4f..95d3629f0 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -184,6 +184,9 @@ updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId) User{userMaxFavourites} <- MaybeT $ get uid + -- TODO optimize for `userMaxFavourites == 0` + -- no need to store (upsert?) them, since they will be removed in the pruning step anyway! + -- update Favourites for_ mcid $ \cid -> void . lift $ upsertBy diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b9186f509..0208a124c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -34,3 +34,4 @@ postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this cou postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () postCFavouriteR _ _ _ = error "not implemented" +-- TODO Route for Icon to toggle manual Favorite diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index abad8669c..5e9991cf1 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Handler.Course.Show ( getCShowR , getCRegisterTemplateR, courseRegisterTemplateSource @@ -26,6 +28,55 @@ import qualified Data.Conduit.List as C import Handler.Exam.List (mkExamTable) +data CourseFavouriteToggleButton + = BtnCourseFavouriteToggleManual + | BtnCourseFavouriteToggleAutomatic + | BtnCourseFavouriteToggleOff + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe CourseFavouriteToggleButton +instance Finite CourseFavouriteToggleButton + +nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 + +instance Button UniWorX CourseFavouriteToggleButton where + btnLabel BtnCourseFavouriteToggleManual = toWidget iconCourseFavouriteManual + btnLabel BtnCourseFavouriteToggleAutomatic = toWidget iconCourseFavouriteAutomatic + btnLabel BtnCourseFavouriteToggleOff = toWidget iconCourseFavouriteOff + + btnClasses _ = [BCIsButton] + +newtype CourseFavouriteToggleForm = CourseFavouriteToggleForm + { cftfFavouriteReason :: Maybe FavouriteReason + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Default, FromJSON, ToJSON) + +makeLenses_ ''CourseFavouriteToggleForm + +-- inspired by examAutoOccurrenceIgnoreRoomsForm +courseFavouriteToggleForm :: TermId -> SchoolId -> CourseShorthand -> CourseFavouriteToggleForm -> Form CourseFavouriteToggleForm +courseFavouriteToggleForm tid ssh csh protoForm html = do + -- create all buttons + (btnResManual, wgtManual) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleManual]) html + (btnResAutomatic, wgtAutomatic) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleAutomatic]) html + (btnResOff, wgtOff) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleOff]) html + + -- choose the relevant button to display + let btnRes = btnResManual <|> btnResAutomatic <|> btnResOff + (wgt, res) = case btnRes of + (FormSuccess BtnCourseFavouriteToggleManual) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent) + -- TODO participants can't remove favourite? + (FormSuccess BtnCourseFavouriteToggleAutomatic) -> (wgtOff, FormSuccess $ CourseFavouriteToggleForm Nothing) + (FormSuccess BtnCourseFavouriteToggleOff) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent) + _otherwise -> (,FormMissing) $ case cftfFavouriteReason protoForm of + Nothing -> wgtOff + (Just FavouriteVisited) -> wgtAutomatic + -- TODO participants can't remove favourite? + (Just FavouriteParticipant) -> wgtAutomatic + (Just FavouriteManual) -> wgtManual + (Just FavouriteCurrent) -> wgtAutomatic + return (res, wgt) + +-- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId @@ -259,11 +310,22 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR + favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm tid ssh csh $ CourseFavouriteToggleForm $ Just FavouriteVisited + let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> + wrapForm favouriteToggleView def + { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR + , formEncoding = favouriteToggleEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup")] + } + + let heading = [whamlet| $newline never ^{courseName course} $if not courseVisible && mayEdit \ #{iconInvisible} + ^{favouriteToggleWgt} |] siteLayout heading $ do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4f28d482d..2b5bdd4c6 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -198,6 +198,7 @@ data FormIdentifier | FIDmaterial | FIDCourseNews | FIDCourseEvent + | FIDCourseFavouriteToggle | FIDsubmission | FIDsettings | FIDcorrectors diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index cf553465f..273c374d5 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -37,6 +37,7 @@ data Icon | IconVisible | IconInvisible | IconCourse + | IconCourseFavouriteManual | IconCourseFavouriteAutomatic | IconCourseFavouriteOff | IconEnrolTrue | IconEnrolFalse | IconPlanned @@ -110,6 +111,10 @@ iconText = \case IconVisible -> "eye" IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" + -- TODO find better Icons: https://fontawesome.com/icons?d=gallery&p=2&s=solid + IconCourseFavouriteManual -> "battery-full" + IconCourseFavouriteAutomatic -> "battery-half" + IconCourseFavouriteOff -> "battery-slash" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" IconPlanned -> "cog" From e23a5a64cc1e0b3540666b10ec331efed8669e10 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 1 Apr 2021 11:42:34 +0200 Subject: [PATCH 05/39] chore: button only redirects to postCFavouriteR actual swapping should happen there still need to display the correct button --- src/Handler/Course.hs | 11 +++++++++- src/Handler/Course/Show.hs | 42 +++++++++++--------------------------- 2 files changed, 22 insertions(+), 31 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0208a124c..051875618 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Handler.Course ( module Handler.Course ) where @@ -33,5 +35,12 @@ getCNotesR = postCNotesR postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () -postCFavouriteR _ _ _ = error "not implemented" +postCFavouriteR tid ssh csh = do + -- TODO swap FavouriteReason here + -- TODO participants can't remove favourite? + liftIO $ do + putStrLn "\nswapping FavouriteReason" + print (tid, ssh, csh) + -- show course page again + void $ redirect $ CourseR tid ssh csh CShowR -- TODO Route for Icon to toggle manual Favorite diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 5e9991cf1..6d25eed48 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -45,36 +45,18 @@ instance Button UniWorX CourseFavouriteToggleButton where btnClasses _ = [BCIsButton] -newtype CourseFavouriteToggleForm = CourseFavouriteToggleForm - { cftfFavouriteReason :: Maybe FavouriteReason - } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Default, FromJSON, ToJSON) - -makeLenses_ ''CourseFavouriteToggleForm - -- inspired by examAutoOccurrenceIgnoreRoomsForm -courseFavouriteToggleForm :: TermId -> SchoolId -> CourseShorthand -> CourseFavouriteToggleForm -> Form CourseFavouriteToggleForm -courseFavouriteToggleForm tid ssh csh protoForm html = do - -- create all buttons - (btnResManual, wgtManual) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleManual]) html - (btnResAutomatic, wgtAutomatic) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleAutomatic]) html - (btnResOff, wgtOff) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleOff]) html - - -- choose the relevant button to display - let btnRes = btnResManual <|> btnResAutomatic <|> btnResOff - (wgt, res) = case btnRes of - (FormSuccess BtnCourseFavouriteToggleManual) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent) - -- TODO participants can't remove favourite? - (FormSuccess BtnCourseFavouriteToggleAutomatic) -> (wgtOff, FormSuccess $ CourseFavouriteToggleForm Nothing) - (FormSuccess BtnCourseFavouriteToggleOff) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent) - _otherwise -> (,FormMissing) $ case cftfFavouriteReason protoForm of - Nothing -> wgtOff - (Just FavouriteVisited) -> wgtAutomatic - -- TODO participants can't remove favourite? - (Just FavouriteParticipant) -> wgtAutomatic - (Just FavouriteManual) -> wgtManual - (Just FavouriteCurrent) -> wgtAutomatic - return (res, wgt) +courseFavouriteToggleForm :: Maybe FavouriteReason -> Form () +courseFavouriteToggleForm currentReason html + = over _1 (fmap $ const ()) <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html + where + btn :: CourseFavouriteToggleButton + btn = case currentReason of + Nothing -> BtnCourseFavouriteToggleOff + (Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic + (Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic + (Just FavouriteManual) -> BtnCourseFavouriteToggleManual + (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic -- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -310,7 +292,7 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm tid ssh csh $ CourseFavouriteToggleForm $ Just FavouriteVisited + favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm $ Just FavouriteVisited let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR From f0ddd680d169b3252eccd48be12c51ab997ef244 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 1 Apr 2021 14:29:55 +0200 Subject: [PATCH 06/39] chore: lookup current favourite reason in DB --- src/Handler/Course.hs | 42 +++++++++++++++++++++++++++++++++ src/Handler/Course/Show.hs | 48 +++++++++++++++++++++++++++++++++++--- 2 files changed, 87 insertions(+), 3 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 051875618..c6655dc36 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -6,6 +6,8 @@ module Handler.Course import Import +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course @@ -36,7 +38,47 @@ postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this cou postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () postCFavouriteR tid ssh csh = do + muid <- maybeAuthPair -- TODO swap FavouriteReason here + runDB $ do + -- Nothing means blacklist + -- should never return FavouriteCurrent + currentReason <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + isLecturer = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) + isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do + E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) + isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) + isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + + reason = E.case_ + [ E.when_ isBlacklist E.then_ E.nothing, + E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant + ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) + pure reason + -- TODO change stored reason in DB + -- TODO participants can't remove favourite (only toggle between automatic/manual)? + pure () + -- TODO participants can't remove favourite? liftIO $ do putStrLn "\nswapping FavouriteReason" diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 6d25eed48..74feea6a3 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -62,8 +62,9 @@ courseFavouriteToggleForm currentReason html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId + muid <- maybeAuthPair now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -166,7 +167,43 @@ getCShowR tid ssh csh = do return $ material E.^. MaterialName mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) + + -- Nothing means blacklist + -- inner maybe is reason stored in database + favouriteReason <- lift . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + isLecturer = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) + isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do + E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) + isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) + isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + + reason = E.case_ + [ E.when_ isBlacklist E.then_ E.nothing, + E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant + ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) + pure reason + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -292,7 +329,12 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm $ Just FavouriteVisited + let favouriteReason = case favouriteReason' of + [E.Value Nothing] -> Nothing + [E.Value (Just (Just reason))] -> Just reason + -- should only be [E.Value (Just Nothing)] + _otherwise -> Just FavouriteVisited + favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR From 0605e940c65479564f75d10fcf2f4319c4151acc Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Fri, 2 Apr 2021 09:10:31 +0200 Subject: [PATCH 07/39] refactor: use the same function to lookup storedFavouriteReason --- src/Handler/Course.hs | 33 +-------------- src/Handler/Course/Show.hs | 84 ++++++++++++++++++++------------------ 2 files changed, 45 insertions(+), 72 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c6655dc36..6862c8bda 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -43,38 +43,7 @@ postCFavouriteR tid ssh csh = do runDB $ do -- Nothing means blacklist -- should never return FavouriteCurrent - currentReason <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do - E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse - E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.limit 1 -- we know that there is at most one match, but we tell the DB this info too - let isBlacklist = E.exists . E.from $ \courseNoFavourite -> - E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) - E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId - isParticipant = E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - isLecturer = E.exists . E.from $ \lecturer -> - E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) - isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do - E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) - isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) - isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor - - reason = E.case_ - [ E.when_ isBlacklist E.then_ E.nothing, - E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant - ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) - pure reason + currentReason <- storedFavouriteReason tid ssh csh muid -- TODO change stored reason in DB -- TODO participants can't remove favourite (only toggle between automatic/manual)? pure () diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 74feea6a3..ccfa23ef1 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -3,6 +3,7 @@ module Handler.Course.Show ( getCShowR , getCRegisterTemplateR, courseRegisterTemplateSource + , storedFavouriteReason ) where import Import @@ -58,13 +59,54 @@ courseFavouriteToggleForm currentReason html (Just FavouriteManual) -> BtnCourseFavouriteToggleManual (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic +-- Nothing means blacklist +-- Will never return FavouriteCurrent +storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) + -> ReaderT SqlBackend m (Maybe FavouriteReason) +storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + isLecturer = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) + isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do + E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) + isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) + isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + + reason :: E.SqlExpr (E.Value (Maybe FavouriteReason)) + reason = E.case_ + [ E.when_ isBlacklist E.then_ E.nothing, + E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant + ] (E.else_ . E.just $ E.coalesceDefault [courseFavourite E.?. CourseFavouriteReason] (E.val FavouriteVisited)) + pure reason + where + unValueFirst :: [E.Value (Maybe a)] -> Maybe a + unValueFirst = join . fmap E.unValue . listToMaybe + -- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId muid <- maybeAuthPair now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -168,40 +210,7 @@ getCShowR tid ssh csh = do mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - -- Nothing means blacklist - -- inner maybe is reason stored in database - favouriteReason <- lift . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do - E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse - E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.limit 1 -- we know that there is at most one match, but we tell the DB this info too - let isBlacklist = E.exists . E.from $ \courseNoFavourite -> - E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) - E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId - isParticipant = E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - isLecturer = E.exists . E.from $ \lecturer -> - E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) - isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do - E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) - isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) - isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor - - reason = E.case_ - [ E.when_ isBlacklist E.then_ E.nothing, - E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant - ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) - pure reason + favouriteReason <- lift $ storedFavouriteReason tid ssh csh muid return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) @@ -329,11 +338,6 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - let favouriteReason = case favouriteReason' of - [E.Value Nothing] -> Nothing - [E.Value (Just (Just reason))] -> Just reason - -- should only be [E.Value (Just Nothing)] - _otherwise -> Just FavouriteVisited favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def From 0556b769cfc10dd00894e06a1bc5945df1959ef7 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 11:19:37 +0200 Subject: [PATCH 08/39] refactor: don't interpret during lookup --- src/Handler/Course.hs | 1 + src/Handler/Course/Show.hs | 24 ++++++++++++++++++------ 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6862c8bda..78616947a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -43,6 +43,7 @@ postCFavouriteR tid ssh csh = do runDB $ do -- Nothing means blacklist -- should never return FavouriteCurrent + -- Just (Maybe reason, blacklist, associated) currentReason <- storedFavouriteReason tid ssh csh muid -- TODO change stored reason in DB -- TODO participants can't remove favourite (only toggle between automatic/manual)? diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index ccfa23ef1..df405d447 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -59,10 +59,11 @@ courseFavouriteToggleForm currentReason html (Just FavouriteManual) -> BtnCourseFavouriteToggleManual (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic --- Nothing means blacklist +-- (storedReason, isBlacklist, isAssociated) -- Will never return FavouriteCurrent +-- Nothing if no entry for current user (e.g. not logged in) storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) - -> ReaderT SqlBackend m (Maybe FavouriteReason) + -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool, Bool)) storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) @@ -89,16 +90,20 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor - + reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool), E.SqlExpr (E.Value Bool)) + reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist, isAssociated) + {- reason :: E.SqlExpr (E.Value (Maybe FavouriteReason)) reason = E.case_ [ E.when_ isBlacklist E.then_ E.nothing, E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant ] (E.else_ . E.just $ E.coalesceDefault [courseFavourite E.?. CourseFavouriteReason] (E.val FavouriteVisited)) + -} pure reason where - unValueFirst :: [E.Value (Maybe a)] -> Maybe a - unValueFirst = join . fmap E.unValue . listToMaybe + unValueFirst :: [(E.Value (Maybe a), E.Value Bool, E.Value Bool)] -> Maybe (Maybe a, Bool, Bool) + -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised + unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue . over _3 E.unValue) . listToMaybe -- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -106,7 +111,7 @@ getCShowR tid ssh csh = do mbAid <- maybeAuthId muid <- maybeAuthPair now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -338,6 +343,13 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR + let favouriteReason = case favouriteReason' of + -- (reason, blacklist, associated) + (Just (_reason, _blacklist, True)) -> Just FavouriteParticipant + (Just (_reason, True, False)) -> Nothing + (Just (Just reason, False, False)) -> Just reason + (Just (Nothing, False, False)) -> Just FavouriteCurrent + Nothing -> Just FavouriteCurrent favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def From 942c8bd59d05c70c1513994b353dd42ea361b679 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 11:24:41 +0200 Subject: [PATCH 09/39] chore: only write favourites to db when userMaxFavourites>0 --- src/Foundation/Yesod/Middleware.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 95d3629f0..683bb8ab6 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -184,11 +184,9 @@ updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId) User{userMaxFavourites} <- MaybeT $ get uid - -- TODO optimize for `userMaxFavourites == 0` - -- no need to store (upsert?) them, since they will be removed in the pruning step anyway! - -- update Favourites - for_ mcid $ \cid -> + -- no need to store them with userMaxFavourites==0, since they will be removed in the pruning step anyway! + when (userMaxFavourites > 0) $ for_ mcid $ \cid -> void . lift $ upsertBy (UniqueCourseFavourite uid cid) (CourseFavourite uid cid FavouriteVisited now) From a099391c7b23e68f1d6bfb444e8dca23b6728059 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 11:42:51 +0200 Subject: [PATCH 10/39] chore: set maxFavourites for new users to 0 --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index 024a72945..a0bf49f47 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -221,7 +221,7 @@ cookies: secure: "_env:COOKIES_SECURE:true" user-defaults: - max-favourites: 12 + max-favourites: 0 max-favourite-terms: 2 theme: Default date-time-format: "%a %d %b %Y %R" From 01770b4ee286a9a0100359bcc4241b563bf5544c Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 12:45:22 +0200 Subject: [PATCH 11/39] chore: allow postCFavouriteR for everyone --- routes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/routes b/routes index 14332ce5d..dc491efca 100644 --- a/routes +++ b/routes @@ -174,7 +174,7 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !tutor !corrector !exam-corrector !course-registered !course-time !evaluation !exam-office !allocation-admin - /favourite CFavouriteR POST + /favourite CFavouriteR POST !free /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registeredANDcourse-time !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time /register-template CRegisterTemplateR GET !course-time /edit CEditR GET POST From 3f48d5aa0c5d76a9e4d9fe01c310727595235d6b Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 12:48:21 +0200 Subject: [PATCH 12/39] chore: only display favouriteToggle-Button when logged in --- src/Handler/Course/Show.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index df405d447..91fdd1c44 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -365,7 +365,8 @@ getCShowR tid ssh csh = do ^{courseName course} $if not courseVisible && mayEdit \ #{iconInvisible} - ^{favouriteToggleWgt} + $if isJust muid + ^{favouriteToggleWgt} |] siteLayout heading $ do From 91a7e11987e0b9ec6fe9b498f47db33c3c286d86 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 14:49:59 +0200 Subject: [PATCH 13/39] chore: implement favourite/blacklist toggle --- src/Handler/Course.hs | 65 +++++++++++++++++++++++++++++++------------ 1 file changed, 47 insertions(+), 18 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 78616947a..da9a491bd 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -7,7 +7,7 @@ module Handler.Course import Import import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E +import qualified Database.Persist as P import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course @@ -37,22 +37,51 @@ getCNotesR = postCNotesR postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () -postCFavouriteR tid ssh csh = do +postCFavouriteR tid ssh csh = void $ do muid <- maybeAuthPair - -- TODO swap FavouriteReason here - runDB $ do - -- Nothing means blacklist - -- should never return FavouriteCurrent - -- Just (Maybe reason, blacklist, associated) - currentReason <- storedFavouriteReason tid ssh csh muid - -- TODO change stored reason in DB - -- TODO participants can't remove favourite (only toggle between automatic/manual)? - pure () - - -- TODO participants can't remove favourite? - liftIO $ do - putStrLn "\nswapping FavouriteReason" - print (tid, ssh, csh) + runDB $ void $ do + mcid <- fmap (fmap E.unValue . listToMaybe) . E.select . E.from $ \course -> do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + pure $ course E.^. CourseId + if | Just cid <- mcid, Just uid <- view _1 <$> muid -> do + now <- liftIO getCurrentTime + -- Nothing means blacklist + -- should never return FavouriteCurrent + (maybeReason, blacklist) <- storedFavouriteReason tid ssh csh muid >>= pure . \case + -- Maybe (Maybe reason, blacklist, associated) + Nothing -> (Just FavouriteManual, False) + -- participants can't remove favourite (only toggle between automatic/manual) + Just (Just FavouriteManual, _blacklist, True) -> (Just FavouriteVisited, False) + Just (_reason, _blacklist, True) -> (Just FavouriteManual, False) + Just (_reason, True, False) -> (Just FavouriteVisited, False) + Just (Just FavouriteManual, False, False) -> (Nothing, True) + Just (_reason, False, False) -> (Just FavouriteManual, False) + -- change stored reason in DB + before <- storedFavouriteReason tid ssh csh muid + if blacklist + then do + E.deleteBy $ UniqueCourseFavourite uid cid + void $ E.upsertBy + (UniqueCourseNoFavourite uid cid) + (CourseNoFavourite uid cid) + [] -- entry shouldn't exists, but keep it unchanged anyway + else do + case maybeReason of + (Just reason) -> void $ E.upsertBy + (UniqueCourseFavourite uid cid) + (CourseFavourite uid cid reason now) + [P.Update CourseFavouriteReason reason P.Assign] + -- [CourseFavouriteReason E.=. E.val reason] + Nothing -> E.deleteBy $ UniqueCourseFavourite uid cid + E.deleteBy $ UniqueCourseNoFavourite uid cid + after <- storedFavouriteReason tid ssh csh muid + liftIO $ do + putStrLn $ "before: " <> pack (show before) + putStrLn $ "after: " <> pack (show after) + print (maybeReason, blacklist) + | otherwise -> pure () -- show course page again - void $ redirect $ CourseR tid ssh csh CShowR --- TODO Route for Icon to toggle manual Favorite + redirect $ CourseR tid ssh csh CShowR From 56c26f3e5142e6f42e8b7265b915955e262ab72a Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 14:52:00 +0200 Subject: [PATCH 14/39] chore: remove -Wwarn marker --- src/Handler/Course.hs | 2 -- src/Handler/Course/Show.hs | 2 -- 2 files changed, 4 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index da9a491bd..46a97ee5f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wwarn #-} - module Handler.Course ( module Handler.Course ) where diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 91fdd1c44..66b53bf74 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wwarn #-} - module Handler.Course.Show ( getCShowR , getCRegisterTemplateR, courseRegisterTemplateSource From 664c915065e9109093f034f4fcadf189fe54da50 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 14:55:43 +0200 Subject: [PATCH 15/39] chore: remove debug messages --- src/Handler/Course.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 46a97ee5f..d263c7757 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -58,7 +58,6 @@ postCFavouriteR tid ssh csh = void $ do Just (Just FavouriteManual, False, False) -> (Nothing, True) Just (_reason, False, False) -> (Just FavouriteManual, False) -- change stored reason in DB - before <- storedFavouriteReason tid ssh csh muid if blacklist then do E.deleteBy $ UniqueCourseFavourite uid cid @@ -75,11 +74,6 @@ postCFavouriteR tid ssh csh = void $ do -- [CourseFavouriteReason E.=. E.val reason] Nothing -> E.deleteBy $ UniqueCourseFavourite uid cid E.deleteBy $ UniqueCourseNoFavourite uid cid - after <- storedFavouriteReason tid ssh csh muid - liftIO $ do - putStrLn $ "before: " <> pack (show before) - putStrLn $ "after: " <> pack (show after) - print (maybeReason, blacklist) | otherwise -> pure () -- show course page again redirect $ CourseR tid ssh csh CShowR From 7896c0bb1632217cd400760257b41642d9b582b8 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 15:13:07 +0200 Subject: [PATCH 16/39] chore: remove special case for participants --- src/Handler/Course.hs | 34 ++++++++++++----------------- src/Handler/Course/Show.hs | 44 +++++++++----------------------------- 2 files changed, 24 insertions(+), 54 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index d263c7757..2a0e564b0 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -48,32 +48,26 @@ postCFavouriteR tid ssh csh = void $ do now <- liftIO getCurrentTime -- Nothing means blacklist -- should never return FavouriteCurrent - (maybeReason, blacklist) <- storedFavouriteReason tid ssh csh muid >>= pure . \case - -- Maybe (Maybe reason, blacklist, associated) - Nothing -> (Just FavouriteManual, False) - -- participants can't remove favourite (only toggle between automatic/manual) - Just (Just FavouriteManual, _blacklist, True) -> (Just FavouriteVisited, False) - Just (_reason, _blacklist, True) -> (Just FavouriteManual, False) - Just (_reason, True, False) -> (Just FavouriteVisited, False) - Just (Just FavouriteManual, False, False) -> (Nothing, True) - Just (_reason, False, False) -> (Just FavouriteManual, False) + newReason <- storedFavouriteReason tid ssh csh muid >>= pure . \case + -- Maybe (Maybe reason, blacklist) + Nothing -> Just FavouriteManual + Just (_reason, True) -> Just FavouriteVisited + Just (Just FavouriteManual, False) -> Nothing + Just (_reason, False) -> Just FavouriteManual -- change stored reason in DB - if blacklist - then do + case newReason of + (Just reason) -> do + void $ E.upsertBy + (UniqueCourseFavourite uid cid) + (CourseFavourite uid cid reason now) + [P.Update CourseFavouriteReason reason P.Assign] + E.deleteBy $ UniqueCourseNoFavourite uid cid + Nothing -> do E.deleteBy $ UniqueCourseFavourite uid cid void $ E.upsertBy (UniqueCourseNoFavourite uid cid) (CourseNoFavourite uid cid) [] -- entry shouldn't exists, but keep it unchanged anyway - else do - case maybeReason of - (Just reason) -> void $ E.upsertBy - (UniqueCourseFavourite uid cid) - (CourseFavourite uid cid reason now) - [P.Update CourseFavouriteReason reason P.Assign] - -- [CourseFavouriteReason E.=. E.val reason] - Nothing -> E.deleteBy $ UniqueCourseFavourite uid cid - E.deleteBy $ UniqueCourseNoFavourite uid cid | otherwise -> pure () -- show course page again redirect $ CourseR tid ssh csh CShowR diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 66b53bf74..df845f544 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -61,7 +61,7 @@ courseFavouriteToggleForm currentReason html -- Will never return FavouriteCurrent -- Nothing if no entry for current user (e.g. not logged in) storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) - -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool, Bool)) + -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool)) storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) @@ -72,36 +72,13 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ let isBlacklist = E.exists . E.from $ \courseNoFavourite -> E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId - isParticipant = E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - isLecturer = E.exists . E.from $ \lecturer -> - E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) - isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do - E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) - isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) - isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor - reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool), E.SqlExpr (E.Value Bool)) - reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist, isAssociated) - {- - reason :: E.SqlExpr (E.Value (Maybe FavouriteReason)) - reason = E.case_ - [ E.when_ isBlacklist E.then_ E.nothing, - E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant - ] (E.else_ . E.just $ E.coalesceDefault [courseFavourite E.?. CourseFavouriteReason] (E.val FavouriteVisited)) - -} + reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool)) + reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist) pure reason where - unValueFirst :: [(E.Value (Maybe a), E.Value Bool, E.Value Bool)] -> Maybe (Maybe a, Bool, Bool) + unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool) -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised - unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue . over _3 E.unValue) . listToMaybe + unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe -- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -342,12 +319,11 @@ getCShowR tid ssh csh = do mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR let favouriteReason = case favouriteReason' of - -- (reason, blacklist, associated) - (Just (_reason, _blacklist, True)) -> Just FavouriteParticipant - (Just (_reason, True, False)) -> Nothing - (Just (Just reason, False, False)) -> Just reason - (Just (Nothing, False, False)) -> Just FavouriteCurrent - Nothing -> Just FavouriteCurrent + -- (reason, blacklist) + (Just (_reason, True)) -> Nothing + (Just (Just reason, False)) -> Just reason + (Just (Nothing, False)) -> Just FavouriteCurrent + Nothing -> Just FavouriteCurrent favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def From ebe676d39d0eb35d74abeda281f994dc7f5e223a Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 15:31:37 +0200 Subject: [PATCH 17/39] refactor: hlint --- src/Handler/Course.hs | 4 ++-- src/Handler/Course/Show.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2a0e564b0..f4cd36c77 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -48,12 +48,12 @@ postCFavouriteR tid ssh csh = void $ do now <- liftIO getCurrentTime -- Nothing means blacklist -- should never return FavouriteCurrent - newReason <- storedFavouriteReason tid ssh csh muid >>= pure . \case + newReason <- storedFavouriteReason tid ssh csh muid <&> (\case -- Maybe (Maybe reason, blacklist) Nothing -> Just FavouriteManual Just (_reason, True) -> Just FavouriteVisited Just (Just FavouriteManual, False) -> Nothing - Just (_reason, False) -> Just FavouriteManual + Just (_reason, False) -> Just FavouriteManual) -- change stored reason in DB case newReason of (Just reason) -> do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index df845f544..0b9380cee 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -47,7 +47,7 @@ instance Button UniWorX CourseFavouriteToggleButton where -- inspired by examAutoOccurrenceIgnoreRoomsForm courseFavouriteToggleForm :: Maybe FavouriteReason -> Form () courseFavouriteToggleForm currentReason html - = over _1 (fmap $ const ()) <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html + = over _1 void <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html where btn :: CourseFavouriteToggleButton btn = case currentReason of From ad6671ed10146d472147d1ba1e7998615752eb7a Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 16:41:33 +0200 Subject: [PATCH 18/39] chore: use star icons --- src/Handler/Course/Show.hs | 11 +++++++++-- src/Utils/Icon.hs | 6 +++--- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 0b9380cee..cbfb14193 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -40,7 +40,14 @@ nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 instance Button UniWorX CourseFavouriteToggleButton where btnLabel BtnCourseFavouriteToggleManual = toWidget iconCourseFavouriteManual btnLabel BtnCourseFavouriteToggleAutomatic = toWidget iconCourseFavouriteAutomatic - btnLabel BtnCourseFavouriteToggleOff = toWidget iconCourseFavouriteOff + btnLabel BtnCourseFavouriteToggleOff = [whamlet| + $newline never + + + ^{iconCourseFavouriteManual} + + ^{iconCourseFavouriteOff} + |] btnClasses _ = [BCIsButton] @@ -80,7 +87,6 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe --- TODO add toggle Manual favorite Icon here getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId @@ -318,6 +324,7 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR + -- TODO use different style for button (neutral background?) let favouriteReason = case favouriteReason' of -- (reason, blacklist) (Just (_reason, True)) -> Nothing diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 273c374d5..a8be79b11 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -112,9 +112,9 @@ iconText = \case IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" -- TODO find better Icons: https://fontawesome.com/icons?d=gallery&p=2&s=solid - IconCourseFavouriteManual -> "battery-full" - IconCourseFavouriteAutomatic -> "battery-half" - IconCourseFavouriteOff -> "battery-slash" + IconCourseFavouriteManual -> "star" + IconCourseFavouriteAutomatic -> "star-half-alt" + IconCourseFavouriteOff -> "slash" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" IconPlanned -> "cog" From 9da26e9ae16e5dc75ac2ea299d3cb11ec531fe76 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Tue, 6 Apr 2021 16:52:53 +0200 Subject: [PATCH 19/39] chore: add BCLink-class to avoid outline --- src/Handler/Course/Show.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index cbfb14193..896ddf271 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -49,7 +49,7 @@ instance Button UniWorX CourseFavouriteToggleButton where ^{iconCourseFavouriteOff} |] - btnClasses _ = [BCIsButton] + btnClasses _ = [BCIsButton, BCLink] -- inspired by examAutoOccurrenceIgnoreRoomsForm courseFavouriteToggleForm :: Maybe FavouriteReason -> Form () From 712dcfbf9d21920f648c21549d37677acc1b1f4f Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 13:41:02 +0200 Subject: [PATCH 20/39] chore: adjust icon size --- src/Handler/Course/Show.hs | 20 ++++++++------------ src/Utils/Icon.hs | 19 +++++++++++++++++++ 2 files changed, 27 insertions(+), 12 deletions(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 896ddf271..d21f04646 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -38,16 +38,12 @@ instance Finite CourseFavouriteToggleButton nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 instance Button UniWorX CourseFavouriteToggleButton where - btnLabel BtnCourseFavouriteToggleManual = toWidget iconCourseFavouriteManual - btnLabel BtnCourseFavouriteToggleAutomatic = toWidget iconCourseFavouriteAutomatic - btnLabel BtnCourseFavouriteToggleOff = [whamlet| - $newline never - - - ^{iconCourseFavouriteManual} - - ^{iconCourseFavouriteOff} - |] + btnLabel BtnCourseFavouriteToggleManual + = toWidget $ icon2x IconCourseFavouriteManual + btnLabel BtnCourseFavouriteToggleAutomatic + = toWidget $ icon2x IconCourseFavouriteAutomatic + btnLabel BtnCourseFavouriteToggleOff + = toWidget $ iconStacked IconCourseFavouriteManual IconCourseFavouriteOff btnClasses _ = [BCIsButton, BCLink] @@ -324,7 +320,6 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - -- TODO use different style for button (neutral background?) let favouriteReason = case favouriteReason' of -- (reason, blacklist) (Just (_reason, True)) -> Nothing @@ -347,7 +342,8 @@ getCShowR tid ssh csh = do $if not courseVisible && mayEdit \ #{iconInvisible} $if isJust muid - ^{favouriteToggleWgt} + + ^{favouriteToggleWgt} |] siteLayout heading $ do diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a8be79b11..a56b5cc17 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -195,6 +195,25 @@ icon ic = [shamlet| |] +-- Create an icon from font-awesome without additional space at 2x size +icon2x :: Icon -> Markup +icon2x ic + = [shamlet| + $newline never + + |] + +-- Stack two icons from font-awesome without additional space (both at 2x size) +-- stacked Icons are always double size, so they are correctly aligned with those produced by 'icon2x' +iconStacked :: Icon -> Icon -> Markup +iconStacked ic0 ic1 + = [shamlet| + $newline never + + + + |] + -- Create an icon (defaults to "?") with a specified tooltip iconTooltip :: forall site. WidgetFor site () -> Maybe Icon -> Bool -> WidgetFor site () iconTooltip tooltip mIcon isInlineTooltip = let From f99d0716016e0357cec0922e28548a15e55d576b Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 14:25:37 +0200 Subject: [PATCH 21/39] chore: newline experiments --- src/Handler/Course/Show.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index d21f04646..3fd04c983 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -332,7 +332,7 @@ getCShowR tid ssh csh = do { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR , formEncoding = favouriteToggleEncoding , formSubmit = FormNoSubmit - , formAttrs = [("class", "buttongroup")] + , formAttrs = [("class", "buttongroup"), ("style", "display: inline-block")] } @@ -342,7 +342,7 @@ getCShowR tid ssh csh = do $if not courseVisible && mayEdit \ #{iconInvisible} $if isJust muid - + ^{favouriteToggleWgt} |] From 4ddbcc421711fdf2e0231b7a458eda28e2542dbb Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 14:31:25 +0200 Subject: [PATCH 22/39] chore: use css classes --- frontend/src/app.sass | 11 +++++++++++ src/Handler/Course/Show.hs | 4 ++-- src/Utils/Icon.hs | 2 +- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 6ec0a287f..d656a8977 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -275,6 +275,9 @@ button:not(.btn-link), display: grid grid: min-content / auto-flow max-content +.buttongroup--inline + display: inline-block + input[type="submit"][disabled]:not(.btn-link), input[type="button"][disabled]:not(.btn-link), button[disabled]:not(.btn-link), @@ -328,6 +331,14 @@ input[type="button"].btn-info:not(.btn-link):hover, &:not([disabled]):hover color: var(--color-link-hover) +.button--favourite-toggle + font-size: 0.25em + vertical-align: top + +// STACK ICON STYLE +.icon--stacked + vertical-align: top + // GENERAL TABLE STYLES .table margin: 21px 0 diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 3fd04c983..0d7a9d4c4 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -332,7 +332,7 @@ getCShowR tid ssh csh = do { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR , formEncoding = favouriteToggleEncoding , formSubmit = FormNoSubmit - , formAttrs = [("class", "buttongroup"), ("style", "display: inline-block")] + , formAttrs = [("class", "buttongroup buttongroup--inline")] } @@ -342,7 +342,7 @@ getCShowR tid ssh csh = do $if not courseVisible && mayEdit \ #{iconInvisible} $if isJust muid - + ^{favouriteToggleWgt} |] diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a56b5cc17..36d207284 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -209,7 +209,7 @@ iconStacked :: Icon -> Icon -> Markup iconStacked ic0 ic1 = [shamlet| $newline never - + |] From 7a1dc571340d5f4e2ec535915630a9c9d1feff08 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 17:09:51 +0200 Subject: [PATCH 23/39] chore: try out different toggle-button locations --- src/Foundation/Instances.hs | 25 +------- src/Foundation/Instances/ButtonClass.hs | 33 ++++++++++ src/Foundation/SiteLayout.hs | 84 +++++++++++++++++++++++++ src/Handler/Course/Show.hs | 6 +- 4 files changed, 121 insertions(+), 27 deletions(-) create mode 100644 src/Foundation/Instances/ButtonClass.hs diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 6c43332ee..730d0ad29 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -10,7 +10,6 @@ module Foundation.Instances import Import.NoFoundation import qualified Data.Text as Text -import qualified Data.List as List import Data.List (inits) import qualified Yesod.Core.Unsafe as Unsafe @@ -28,6 +27,7 @@ import qualified Foundation.Yesod.StaticContent as UniWorX import qualified Foundation.Yesod.Persist as UniWorX import qualified Foundation.Yesod.Auth as UniWorX +import Foundation.Instances.ButtonClass import Foundation.SiteLayout import Foundation.Type import Foundation.I18n @@ -51,29 +51,6 @@ import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E -data instance ButtonClass UniWorX - = BCIsButton - | BCDefault - | BCPrimary - | BCSuccess - | BCInfo - | BCWarning - | BCDanger - | BCLink - | BCMassInputAdd | BCMassInputDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite) - -instance PathPiece (ButtonClass UniWorX) where - toPathPiece BCIsButton = "btn" - toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass - fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF - -instance Button UniWorX ButtonSubmit where - btnClasses BtnSubmit = [BCIsButton, BCPrimary] - - - -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod UniWorX where diff --git a/src/Foundation/Instances/ButtonClass.hs b/src/Foundation/Instances/ButtonClass.hs new file mode 100644 index 000000000..2a6dfcb78 --- /dev/null +++ b/src/Foundation/Instances/ButtonClass.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Foundation.Instances.ButtonClass (ButtonClass(..)) where + +import Import.NoFoundation + +import Utils.Form +import Foundation.Type +import qualified Data.List as List + +-- instance RenderMessage UniWorX ButtonSubmit +import Foundation.I18n () + + +data instance ButtonClass UniWorX + = BCIsButton + | BCDefault + | BCPrimary + | BCSuccess + | BCInfo + | BCWarning + | BCDanger + | BCLink + | BCMassInputAdd | BCMassInputDelete + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + +instance PathPiece (ButtonClass UniWorX) where + toPathPiece BCIsButton = "btn" + toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass + fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF + +instance Button UniWorX ButtonSubmit where + btnClasses BtnSubmit = [BCIsButton, BCPrimary] diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 267f47385..6c4bb56c1 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -15,6 +15,7 @@ import Foundation.Routes import Foundation.Navigation import Foundation.I18n import Foundation.Yesod.Persist +import Foundation.Instances.ButtonClass import Utils.SystemMessage import Utils.Form @@ -37,6 +38,65 @@ import Text.Cassius (cassiusFile) import Text.Hamlet (hamletFile) import Data.FileEmbed (embedFile) +----------------------------------------------------------------------------------------- +-- copy&paste from Handler.Course.Show for now +data CourseFavouriteToggleButton + = BtnCourseFavouriteToggleManual + | BtnCourseFavouriteToggleAutomatic + | BtnCourseFavouriteToggleOff + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe CourseFavouriteToggleButton +instance Finite CourseFavouriteToggleButton + +nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 + +instance Button UniWorX CourseFavouriteToggleButton where + btnLabel BtnCourseFavouriteToggleManual + = toWidget $ icon2x IconCourseFavouriteManual + btnLabel BtnCourseFavouriteToggleAutomatic + = toWidget $ icon2x IconCourseFavouriteAutomatic + btnLabel BtnCourseFavouriteToggleOff + = toWidget $ iconStacked IconCourseFavouriteManual IconCourseFavouriteOff + + btnClasses _ = [BCIsButton, BCLink] + +-- inspired by examAutoOccurrenceIgnoreRoomsForm +courseFavouriteToggleForm :: Maybe FavouriteReason -> Form () +courseFavouriteToggleForm currentReason html + = over _1 void <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html + where + btn :: CourseFavouriteToggleButton + btn = case currentReason of + Nothing -> BtnCourseFavouriteToggleOff + (Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic + (Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic + (Just FavouriteManual) -> BtnCourseFavouriteToggleManual + (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic + +-- (storedReason, isBlacklist, isAssociated) +-- Will never return FavouriteCurrent +-- Nothing if no entry for current user (e.g. not logged in) +storedFavouriteReason :: (MonadIO m, BearerAuthSite UniWorX) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) + -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool)) +storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool)) + reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist) + pure reason + where + unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool) + -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised + unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe +--------------------------------------------------------------------------------------- + data MemcachedKeyFavourites = MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang) @@ -201,6 +261,30 @@ siteLayout' overrideHeading widget = do , maybe userDefaultTheme userTheme $ view _2 <$> muid ) + -------------------------------------- + muid <- maybeAuthPair + (currentReason', maybeRoute) <- case mcurrentRoute of + (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> runDB (storedFavouriteReason tid ssh csh muid) + _otherwise -> pure (Nothing, Nothing) + let currentReason = case currentReason' of + -- (reason, blacklist) + (Just (_reason, True)) -> Nothing + (Just (Just reason, False)) -> Just reason + (Just (Nothing, False)) -> Just FavouriteCurrent + Nothing -> Just FavouriteCurrent + showFavToggle :: FavouriteReason -> Bool + showFavToggle FavouriteCurrent = isJust muid + showFavToggle _favouriteReason = False + favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm currentReason + let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> + wrapForm favouriteToggleView def + { formAction = maybeRoute + , formEncoding = favouriteToggleEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup buttongroup--inline")] + } + ------------------------------------- + let favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites' diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 0d7a9d4c4..b54302676 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -338,12 +338,12 @@ getCShowR tid ssh csh = do let heading = [whamlet| $newline never + $if isJust muid + + ^{favouriteToggleWgt} # ^{courseName course} $if not courseVisible && mayEdit \ #{iconInvisible} - $if isJust muid - - ^{favouriteToggleWgt} |] siteLayout heading $ do From 0e7e042ef8afc72611042b4ca16f290a71344616 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 17:33:53 +0200 Subject: [PATCH 24/39] chore: only show favourite-toggle in sidenav + code cleanup --- frontend/src/app.sass | 2 +- src/Foundation/SiteLayout.hs | 8 +-- src/Handler/Course/Show.hs | 82 +--------------------- templates/widgets/asidenav/asidenav.hamlet | 3 + 4 files changed, 8 insertions(+), 87 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index d656a8977..fccc3a85a 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -332,7 +332,7 @@ input[type="button"].btn-info:not(.btn-link):hover, color: var(--color-link-hover) .button--favourite-toggle - font-size: 0.25em + font-size: 0.5em vertical-align: top // STACK ICON STYLE diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 6c4bb56c1..8b58cad65 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -5,6 +5,7 @@ module Foundation.SiteLayout ( siteLayout', siteLayout , siteLayoutMsg', siteLayoutMsg , getSystemMessageState + , storedFavouriteReason ) where import Import.NoFoundation hiding (embedFile, runDB) @@ -38,8 +39,6 @@ import Text.Cassius (cassiusFile) import Text.Hamlet (hamletFile) import Data.FileEmbed (embedFile) ------------------------------------------------------------------------------------------ --- copy&paste from Handler.Course.Show for now data CourseFavouriteToggleButton = BtnCourseFavouriteToggleManual | BtnCourseFavouriteToggleAutomatic @@ -73,7 +72,7 @@ courseFavouriteToggleForm currentReason html (Just FavouriteManual) -> BtnCourseFavouriteToggleManual (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic --- (storedReason, isBlacklist, isAssociated) +-- (storedReason, isBlacklist) -- Will never return FavouriteCurrent -- Nothing if no entry for current user (e.g. not logged in) storedFavouriteReason :: (MonadIO m, BearerAuthSite UniWorX) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) @@ -95,7 +94,6 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool) -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe ---------------------------------------------------------------------------------------- data MemcachedKeyFavourites @@ -261,7 +259,6 @@ siteLayout' overrideHeading widget = do , maybe userDefaultTheme userTheme $ view _2 <$> muid ) - -------------------------------------- muid <- maybeAuthPair (currentReason', maybeRoute) <- case mcurrentRoute of (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> runDB (storedFavouriteReason tid ssh csh muid) @@ -283,7 +280,6 @@ siteLayout' overrideHeading widget = do , formSubmit = FormNoSubmit , formAttrs = [("class", "buttongroup buttongroup--inline")] } - ------------------------------------- let favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites' diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index b54302676..fe15da01a 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,7 +1,6 @@ module Handler.Course.Show ( getCShowR , getCRegisterTemplateR, courseRegisterTemplateSource - , storedFavouriteReason ) where import Import @@ -27,68 +26,11 @@ import qualified Data.Conduit.List as C import Handler.Exam.List (mkExamTable) -data CourseFavouriteToggleButton - = BtnCourseFavouriteToggleManual - | BtnCourseFavouriteToggleAutomatic - | BtnCourseFavouriteToggleOff - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe CourseFavouriteToggleButton -instance Finite CourseFavouriteToggleButton - -nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 - -instance Button UniWorX CourseFavouriteToggleButton where - btnLabel BtnCourseFavouriteToggleManual - = toWidget $ icon2x IconCourseFavouriteManual - btnLabel BtnCourseFavouriteToggleAutomatic - = toWidget $ icon2x IconCourseFavouriteAutomatic - btnLabel BtnCourseFavouriteToggleOff - = toWidget $ iconStacked IconCourseFavouriteManual IconCourseFavouriteOff - - btnClasses _ = [BCIsButton, BCLink] - --- inspired by examAutoOccurrenceIgnoreRoomsForm -courseFavouriteToggleForm :: Maybe FavouriteReason -> Form () -courseFavouriteToggleForm currentReason html - = over _1 void <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html - where - btn :: CourseFavouriteToggleButton - btn = case currentReason of - Nothing -> BtnCourseFavouriteToggleOff - (Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic - (Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic - (Just FavouriteManual) -> BtnCourseFavouriteToggleManual - (Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic - --- (storedReason, isBlacklist, isAssociated) --- Will never return FavouriteCurrent --- Nothing if no entry for current user (e.g. not logged in) -storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) - -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool)) -storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do - E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse - E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.limit 1 -- we know that there is at most one match, but we tell the DB this info too - let isBlacklist = E.exists . E.from $ \courseNoFavourite -> - E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) - E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId - reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool)) - reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist) - pure reason - where - unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool) - -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised - unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe - getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - muid <- maybeAuthPair now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -192,9 +134,7 @@ getCShowR tid ssh csh = do mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - favouriteReason <- lift $ storedFavouriteReason tid ssh csh muid - - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -320,27 +260,9 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - let favouriteReason = case favouriteReason' of - -- (reason, blacklist) - (Just (_reason, True)) -> Nothing - (Just (Just reason, False)) -> Just reason - (Just (Nothing, False)) -> Just FavouriteCurrent - Nothing -> Just FavouriteCurrent - favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason - let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> - wrapForm favouriteToggleView def - { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR - , formEncoding = favouriteToggleEncoding - , formSubmit = FormNoSubmit - , formAttrs = [("class", "buttongroup buttongroup--inline")] - } - let heading = [whamlet| $newline never - $if isJust muid - - ^{favouriteToggleWgt} # ^{courseName course} $if not courseVisible && mayEdit \ #{iconInvisible} diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index da4b8a010..336018a10 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -29,6 +29,9 @@ $newline never #{cName} $if mayEdit && not courseVisible \ #{iconInvisible} + $if showFavToggle favReason + + ^{favouriteToggleWgt} #

$maybe pageActions <- mPageActions