From 0e7e042ef8afc72611042b4ca16f290a71344616 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 8 Apr 2021 17:33:53 +0200 Subject: [PATCH] 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