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