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" diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 6ec0a287f..f6bd8a949 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-grid + input[type="submit"][disabled]:not(.btn-link), input[type="button"][disabled]:not(.btn-link), button[disabled]:not(.btn-link), @@ -328,6 +331,10 @@ input[type="button"].btn-info:not(.btn-link):hover, &:not([disabled]):hover color: var(--color-link-hover) +// STACK ICON STYLE +.icon--stacked + font-size: 0.5rem + // GENERAL TABLE STYLES .table margin: 21px 0 diff --git a/frontend/src/utils/asidenav/asidenav.sass b/frontend/src/utils/asidenav/asidenav.sass index c6d6b070e..5bca8b347 100644 --- a/frontend/src/utils/asidenav/asidenav.sass +++ b/frontend/src/utils/asidenav/asidenav.sass @@ -1,3 +1,6 @@ +@use "../../common" as * +@use "../../app" as * + .main__aside position: fixed box-shadow: 0 0 10px rgba(0, 0, 0, 0.3) @@ -90,6 +93,18 @@ padding: 0 13px margin: 3px 0 +.asidenav__box-explanation + @extend .explanation + padding: 0 13px + margin: 3px 0 + opacity: .66 + font-size: .7rem + + /* transition: opacity .2s ease, font-size .2s ease + /* &:hover + /* font-size: .9rem + /* opacity: 1 + // LOGO .asidenav__logo @@ -217,9 +232,30 @@ .asidenav__link-shorthand display: none +.asidenav__link-favourite-toggle + opacity: .33 + + &:hover + opacity: 1 + + button + display: flex + text-decoration: none + .asidenav__link-label + display: flex + justify-content: space-between + align-items: center line-height: 1 + & > .asidenav__link-label-text + word-break: break-word + flex: 1 1 auto + + & > .asidenav__link-favourite-toggle + flex: 0 0 $fa-fw-width + margin: 0 5px + // hover sub-menus .asidenav__nested-list-wrapper position: absolute diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 5744e0781..040f301c5 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -2682,6 +2682,8 @@ FavouriteParticipant: Ihre Kurse FavouriteManual: Favoriten FavouriteCurrent: Aktueller Kurs +FavouritesEmptyTip: Hier werden Ihre Kurse, sowie zuletzt besuchte Kurse angezeigt. +FavouritesToggleTip: Der Anzeigemodus für den aktuellen Kurs kann über einen Klick auf das Stern-Symbol zwischen automatisch, permanent und nie gewechselt werden. FavouritesUnavailableTip: Das Schnellzugriffsmenü für diesen Kurs ist aktuell nicht verfügbar. CourseEvents: Termine @@ -3228,4 +3230,4 @@ CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle i CorrectionInvisibleExamUnfinished: Die Frist „_{MsgExamFinished}“ für die relevante Prüfung ist noch nicht verstrichen CorrectionInvisibleRatingNotDone: Die Bewertung ist nicht als „Abgeschlossen“ markiert CorrectionInvisibleWarning: Die Bewertung dieser Abgabe ist aktuell für mindestens eine an der Abgabe beteiligte Person nicht sichtbar! -CorrectionInvisibleReasons: Mögliche Gründe hierfür: \ No newline at end of file +CorrectionInvisibleReasons: Mögliche Gründe hierfür: diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index cdbf8e2f2..bf2d4861c 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -2682,6 +2682,8 @@ FavouriteParticipant: Your courses FavouriteManual: Favourites FavouriteCurrent: Current course +FavouritesEmptyTip: Your courses and recently visited courses are shown here. +FavouritesToggleTip: The display mode for the current course can be changed between automatic, permanent and never with a click on the star symbol. FavouritesUnavailableTip: Quick Actions for this course are currently not available. CourseEvents: Occurrences diff --git a/routes b/routes index 14332ce5d..223c0114e 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 GET 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 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..f7d2a0192 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) @@ -15,6 +16,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 +39,61 @@ import Text.Cassius (cassiusFile) import Text.Hamlet (hamletFile) import Data.FileEmbed (embedFile) +data CourseFavouriteToggleButton + = BtnCourseFavouriteToggleManual + | BtnCourseFavouriteToggleAutomatic + | BtnCourseFavouriteToggleOff + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4 + +instance Button UniWorX CourseFavouriteToggleButton where + btnLabel BtnCourseFavouriteToggleManual + = toWidget $ iconFixed IconCourseFavouriteManual + btnLabel BtnCourseFavouriteToggleAutomatic + = toWidget $ iconFixed 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) +-- 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 (bimap E.unValue E.unValue) . listToMaybe + data MemcachedKeyFavourites = MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang) @@ -94,11 +151,11 @@ siteLayout' overrideHeading widget = do now <- liftIO getCurrentTime + muid <- maybeAuthPair -- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible - (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme) <- do - muid <- maybeAuthPair + (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme, storedReasonAndToggleRoute) <- do - (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) <- runDB $ do + (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute) <- runDB $ do favCourses'' <- 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) @@ -189,8 +246,12 @@ siteLayout' overrideHeading widget = do forM_ authTagPivots $ \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages + + storedReasonAndToggleRoute <- case mcurrentRoute of + (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> storedFavouriteReason tid ssh csh muid + _otherwise -> pure (Nothing, Nothing) - return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) + return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute) return ( favCourses , breadcrumbs'' @@ -199,10 +260,37 @@ siteLayout' overrideHeading widget = do , mmsgs , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid , maybe userDefaultTheme userTheme $ view _2 <$> muid + , storedReasonAndToggleRoute ) + let (currentReason', maybeRoute) = storedReasonAndToggleRoute + 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' + favouriteTerms = Set.toDescList . prune $ toTermKeySet favourites' + where + prune ts = currentTerms `Set.union` setTakeEnd (maxFavouriteTerms - Set.size currentTerms) (ts `Set.difference` currentTerms) + setTakeEnd n ts + | n <= 0 = Set.empty + | otherwise = Set.drop (Set.size ts - n) ts + currentTerms = toTermKeySet $ filter (views (_2 . _Value) . maybe True $ is _FavouriteCurrent) favourites' + toTermKeySet = setOf $ folded . _1 . _2 . to unTermKey favourites <- fmap catMaybes . forM favourites' $ \(c@(_, tid, ssh, csh), E.Value mFavourite, courseVisible, mayView, mayEdit) -> let courseRoute = CourseR tid ssh csh CShowR @@ -251,6 +339,8 @@ siteLayout' overrideHeading widget = do favouriteTermReason tid favReason' = favourites & filter (\((_, tid', _, _), _, _, favReason, _, _, _) -> unTermKey tid' == tid && favReason == favReason') & sortOn (\((cName, _, _, _), _, _, _, _, _, _) -> cName) + anyFavToggle = flip any ((,) <$> universeF <*> favouriteTerms) $ \(reason, term) -> + showFavToggle reason && not (null $ favouriteTermReason term reason) -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3aa73ab4f..683bb8ab6 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -185,7 +185,8 @@ updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do User{userMaxFavourites} <- MaybeT $ get uid -- 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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b9186f509..0247f13b8 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -4,6 +4,8 @@ module Handler.Course import Import +import qualified Database.Esqueleto as E +import qualified Database.Persist as P import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course @@ -32,5 +34,35 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCNotesR = postCNotesR postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] +-- simple redirect for now to avoid running into HTTP method not supported. +getCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () +getCFavouriteR tid ssh csh = redirect $ CourseR tid ssh csh CShowR postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () -postCFavouriteR _ _ _ = error "not implemented" +postCFavouriteR tid ssh csh = void $ do + authPair@(uid, _) <- requireAuthPair + runDB $ void $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + -- should never return FavouriteCurrent + newReason <- storedFavouriteReason tid ssh csh (Just authPair) <&> (\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 + 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 + -- show course page again + redirect $ CourseR tid ssh csh CShowR diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 6bfae3fc6..2369dff95 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -54,8 +54,6 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " derivePersistField "Theme" - - data FavouriteReason = FavouriteVisited | FavouriteParticipant @@ -68,6 +66,9 @@ deriveJSON defaultOptions } ''FavouriteReason derivePersistFieldJSON ''FavouriteReason +makePrisms ''FavouriteReason + + data Sex = SexNotKnown | SexMale 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..be30d24d8 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,9 @@ iconText = \case IconVisible -> "eye" IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" + IconCourseFavouriteManual -> "star" + IconCourseFavouriteAutomatic -> "star-half-alt" + IconCourseFavouriteOff -> "slash" -- TODO use FA regular style star for stacked icon IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" IconPlanned -> "cog" @@ -189,6 +193,23 @@ icon ic = [shamlet| $newline never |] + +-- Create an icon from font-awesome with fixed width +iconFixed :: Icon -> Markup +iconFixed ic = [shamlet| + $newline never + + |] + +-- Stack two icons from font-awesome without additional space +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 () diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index da4b8a010..67f6d890e 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -9,35 +9,46 @@ $newline never _{MsgLogo}
- $forall tid <- favouriteTerms -
-

-
- _{ShortTermIdentifier tid} -
- #{toPathPiece tid} - $forall favReason <- sortOn Down universeF - $if not (null $ favouriteTermReason tid favReason) -

- _{favReason} -