chore: only show favourite-toggle in sidenav + code cleanup

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

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'

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))
-
-    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'
@@ -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
-            <span .button--favourite-toggle>
-              ^{favouriteToggleWgt} #
           ^{courseName course}
           $if not courseVisible && mayEdit
             \ #{iconInvisible}

templates/widgets/asidenav/asidenav.hamlet

@@ -29,6 +29,9 @@ $newline never
                       #{cName}
                       $if mayEdit && not courseVisible
                         \ #{iconInvisible}
+                      $if showFavToggle favReason
+                        <span .button--favourite-toggle>
+                          ^{favouriteToggleWgt} #
                   <div .asidenav__nested-list-wrapper>
                     $maybe pageActions <- mPageActions
                       <ul .asidenav__nested-list.list--iconless>