diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 2568a5dbb..0f098e758 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -160,7 +160,7 @@ h4 --current-header-height: var(--header-height-collapsed) position: relative background-color: white - transition: padding-left .2s ease-out + transition: padding-left .2s ease-out, margin-top 0.2s cubic-bezier(0.03, 0.43, 0.58, 1) margin-top: var(--current-header-height) margin-left: 0 @@ -173,6 +173,9 @@ h4 > .container margin: 20px 0 + .navbar__container-radio:checked ~ * & + margin-top: calc(var(--current-header-height) + 40px) + .main__content, .modal__content a text-decoration: underline @@ -228,6 +231,7 @@ input[type="submit"], input[type="button"], button, .btn + font-family: var(--font-base) outline: 0 border: 0 box-shadow: 0 @@ -639,6 +643,9 @@ section z-index: 19 pointer-events: none + .navbar__container-radio:checked ~ & + top: calc(80px + var(--header-height)) + @media (max-width: 768px) .ribbon top: calc(20px + var(--header-height-collapsed)) diff --git a/frontend/src/utils/navbar/navbar.js b/frontend/src/utils/navbar/navbar.js index 0bb6fb029..4cd12ca8d 100644 --- a/frontend/src/utils/navbar/navbar.js +++ b/frontend/src/utils/navbar/navbar.js @@ -1,48 +1,89 @@ import { Utility } from '../../core/utility'; import './navbar.sass'; +import * as throttle from 'lodash.throttle'; - -export const LANGUAGE_SELECT_UTIL_SELECTOR = '[uw-language-select]'; -const LANGUAGE_SELECT_INITIALIZED_CLASS = 'language-select--initialized'; - +export const HEADER_CONTAINER_UTIL_SELECTOR = '.navbar__list-item--container-selector .navbar__link-wrapper'; +const HEADER_CONTAINER_INITIALIZED_CLASS = '.navbar-header-container--initialized'; @Utility({ - selector: LANGUAGE_SELECT_UTIL_SELECTOR, + selector: HEADER_CONTAINER_UTIL_SELECTOR, }) -export class LanguageSelectUtil { +export class NavHeaderContainerUtil { _element; - checkbox; - + radioButton; + closeButton; + container; + + wasOpen; + + _throttleUpdateWasOpen; + constructor(element) { if (!element) { - throw new Error('Language Select utility needs to be passed an element!'); + throw new Error('Navbar Header Container utility needs to be passed an element!'); } - if (element.classList.contains(LANGUAGE_SELECT_INITIALIZED_CLASS)) { + if (element.classList.contains(HEADER_CONTAINER_INITIALIZED_CLASS)) { return false; } this._element = element; - this.checkbox = element.querySelector('#lang-checkbox'); + this.radioButton = document.getElementById(`${this._element.id}-radio`); + if (!this.radioButton) { + throw new Error('Navbar Header Container utility could not find associated radio button!'); + } - window.addEventListener('click', event => this.close(event)); + this.closeButton = document.getElementById('container-radio-none'); + if (!this.closeButton) { + throw new Error('Navbar Header Container utility could not find radio button for closing!'); + } + + this.container = document.getElementById(`${this._element.id}-container`); + if (!this.container) { + throw new Error('Navbar Header Container utility could not find associated container!'); + } - element.classList.add(LANGUAGE_SELECT_INITIALIZED_CLASS); + const closer = this.container.querySelector('.navbar__container-list-closer'); + if (closer) { + closer.classList.add('navbar__container-list-closer--hidden'); + } + + this.updateWasOpen(); + this.throttleUpdateWasOpen = throttle(this.updateWasOpen.bind(this), 100, { leading: false, trailing: true }); + + this._element.classList.add(HEADER_CONTAINER_INITIALIZED_CLASS); } - close(event) { - if (!this._element.contains(event.target) && window.document.contains(event.target)) { - this.checkbox.checked = false; + start() { + window.addEventListener('click', this.clickHandler.bind(this)); + this.radioButton.addEventListener('change', this.throttleUpdateWasOpen.bind(this)); + } + + clickHandler() { + if (!this.container.contains(event.target) && window.document.contains(event.target) && this.wasOpen) { + this.close(); } } - destroy() { - // TODO + close() { + this.radioButton.checked = false; + this.closeButton.checked = true; + this.throttleUpdateWasOpen(); } + isOpen() { + return this.radioButton.checked; + } + + updateWasOpen() { + this.wasOpen = this.isOpen(); + } + + destroy() { /* TODO */ } } + export const NavbarUtils = [ - LanguageSelectUtil, + NavHeaderContainerUtil, ]; diff --git a/frontend/src/utils/navbar/navbar.sass b/frontend/src/utils/navbar/navbar.sass index 05e3e23ab..8d92ca8b4 100644 --- a/frontend/src/utils/navbar/navbar.sass +++ b/frontend/src/utils/navbar/navbar.sass @@ -21,28 +21,115 @@ .navbar position: fixed - display: flex - flex-direction: row - align-items: center - justify-content: flex-start right: 0 top: 0 left: var(--asidenav-width-xl) - height: var(--header-height) + min-height: var(--header-height) background-color: var(--color-primary) color: white z-index: 20 box-shadow: 0 0 4px rgba(0, 0, 0, 0.2) overflow: auto transition: all 0.2s cubic-bezier(0.03, 0.43, 0.58, 1) + margin: 0 + padding: 10px 0 -@media (max-width: 1199px) - .navbar + @media (max-width: 1199px) left: var(--asidenav-width-lg) -@media (max-width: 768px) - .navbar + @media (max-width: 768px), (max-height: 500px) left: 0 + min-height: var(--header-height-collapsed) + padding: 0 + +@media (max-width: 768px), (max-height: 500px) + .navbar__link-wrapper + height: var(--header-height-collapsed) + +.navbar__list-wrapper + display: flex + flex-flow: row nowrap + justify-content: space-between + align-items: center + margin: 0 40px + + .navbar__list-left + margin-right: 40px + +.navbar__list + display: flex + flex-flow: row nowrap + justify-content: flex-end + align-items: center + list-style-type: none + + &.navbar__list-left + justify-content: flex-start + + & > * + display: block + +.navbar__container-list + position: relative + width: 100% + /* margin: 10px 0 0 0 */ + padding: 0 40px + overflow: hidden + + & > ul + display: flex + flex-flow: row nowrap + align-items: center + overflow: auto + list-style-type: none + justify-content: flex-end + + & > * + display: block + margin-right: 12px + + &:last-child + margin-right: 0 + + &.navbar__container-list--left > ul + justify-content: flex-start + + @media (max-width: 768px), (max-height: 500px) + padding: 0 + + visibility: collapse + margin: 0 + height: 0 + transition: height 0.2s cubic-bezier(0.03, 0.43, 0.58, 1), margin 0.2s cubic-bezier(0.03, 0.43, 0.58, 1) + + .navbar__container-list-closer + position: absolute + top: 5px + right: 10px + width: 20px + height: 20px + text-align: center + + transform-origin: 10px 10px + transform: rotate(-0.25turn) + &.navbar__container-list--left + transform: rotate(0.25turn) + + opacity: 0.5 + transition: transform 0.2s, opacity 0.2s ease + + &:hover + opacity: 1 + + transform: scale(1.4) + + &.navbar__container-list-closer--hidden + visibility: hidden + + &.navbar__container-list--left .navbar__container-list-closer + left: 14.5px + right: auto + // links .navbar__link-wrapper @@ -67,12 +154,13 @@ padding: 2px 4px text-transform: uppercase font-weight: 600 + font-size: 16px -@media (min-width: 769px) +@media (min-width: 769px) and (min-height: 501px) .navbar__link-wrapper border: 1px solid rgba(255, 255, 255, 0.7) -@media (max-width: 768px) +@media (max-width: 768px), (max-height: 500px) .navbar__link-wrapper box-shadow: none min-width: 0 @@ -86,22 +174,42 @@ transform: scale(0.65) margin-bottom: 0 -// navbar list -.navbar__list - white-space: nowrap +.navbar__container-link + display: block + + @media (min-width: 769px) and (min-height: 501px) + border: 1px solid rgba(255, 255, 255, 0.7) + text-decoration: none - + .navbar__list - margin-left: 12px + @media (max-width: 768px), (max-height: 500px) + text-decoration: underline -@media (min-width: 769px) - .navbar__list:last-of-type - padding-right: 40px + height: 30px + color: var(--color-lightwhite) !important + background-color: rgba(0, 0, 0, 0) !important + padding: 5px 10px + text-transform: uppercase + font-weight: 600 + font-size: 16px + outline: 0 + min-width: 0 + transition: none + cursor: pointer + + &:not(.navbar__container-link--active):hover + text-decoration: none + + @media (min-width: 769px) and (min-height: 501px) + background-color: var(--color-dark) !important + color: var(--color-lightwhite) !important + + &.navbar__container-link--active + text-decoration: none + + @media (min-width: 769px) and (min-height: 501px) + background-color: var(--color-lightwhite) !important + color: var(--color-dark) !important -@media (max-width: 768px) - .navbar__list - + .navbar__list - margin-left: 0 - padding-right: 40px // list item .navbar__list-item @@ -124,34 +232,10 @@ &:not(.navbar__list-item--favorite) + .navbar__list-item--lang-wrapper margin-left: 0 -.navbar__list-left - flex: 5 - padding-left: 40px - -@media (max-width: 768px) - .navbar__list-left - padding-left: 0 - // "Favorites" list item, only visible on small screens and logged in -.navbar__list-item - &.navbar__list-item--favorite - display: none - -.navbar__list-item--favorite - display: none - background-color: var(--color-primary) - -.logged-in - .navbar__list - li.navbar__list-item--favorite, - .navbar__list-item--favorite - display: inline-block - @media (min-width: 426px) - .logged-in - .navbar__list - .navbar__list-item--favorite - display: none !important + .navbar__list-item--favorite + display: none !important .navbar__list-item--active background-color: var(--color-lightwhite) @@ -163,7 +247,7 @@ .navbar__list-item--active .navbar__link-wrapper color: var(--color-dark) -.navbar .navbar__list-item:not(.navbar__list-item--active):not(.navbar__list-item--favorite):hover .navbar__link-wrapper, #lang-checkbox:checked ~ * .navbar__link-wrapper +.navbar__list-item:not(.navbar__list-item--active):hover .navbar__link-wrapper background-color: var(--color-dark) color: var(--color-lightwhite) @@ -186,43 +270,5 @@ display: block height: var(--header-height-collapsed) -@media (max-width: 768px) - .navbar, - .navbar__pushdown - height: var(--header-height-collapsed) - - .navbar__link-wrapper - height: var(--header-height-collapsed) - -@media (max-height: 500px) - .navbar, - .navbar__pushdown - height: var(--header-height-collapsed) - - .navbar__link-wrapper - height: var(--header-height-collapsed) - -#lang-dropdown +.navbar__container-radio--none, .navbar__container-radio display: none - position: fixed - top: var(--header-height) - right: 0 - min-width: 200px - z-index: 10 - background-color: white - border-radius: 2px - box-shadow: 0 0 10px rgba(0, 0, 0, 0.3) - - select - display: block - - button - display: block - width: 100% - -#lang-checkbox:checked ~ #lang-dropdown - display: block - -@media (max-width: 768px) - #lang-dropdown - top: var(--header-height-collapsed) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index a5416afe9..1043a6ac0 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -493,7 +493,7 @@ CorrectorsPlaceholder: Korrektoren... CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert. Users: Benutzer -HomeHeading: Aktuelle Termine +NewsHeading: Aktuelles LoginHeading: Authentifizierung LoginTitle: Authentifizierung ProfileHeading: Benutzereinstellungen @@ -508,9 +508,9 @@ NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen f TokensLastReset: Tokens zuletzt invalidiert TokensResetSuccess: Authorisierungs-Tokens invalidiert -HomeOpenAllocations: Offene Zentralanmeldungen -HomeUpcomingSheets: Anstehende Übungsblätter -HomeUpcomingExams: Bevorstehende Prüfungen +NewsOpenAllocations: Offene Zentralanmeldungen +NewsUpcomingSheets: Anstehende Übungsblätter +NewsUpcomingExams: Bevorstehende Prüfungen NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} CloseAlert: Schliessen @@ -1114,7 +1114,7 @@ InvalidRoute: Konnte URL nicht interpretieren MenuOpenCourses: Kurse mit offener Registrierung MenuOpenAllocations: Aktive Zentralanmeldungen -MenuHome: Aktuell +MenuNews: Aktuell MenuInformation: Informationen MenuLegal: Rechtliche Informationen MenuDataProt: Datenschutzerklärung @@ -1561,7 +1561,6 @@ ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten ExamBonusManual': Manuelle Berechnung -ExamGradesExplanation: Diese Ansicht zeigt die selben Daten an, wie die Tabelle von Prüfungsteilnehmern. Anpassen der Teilnehmerdaten und Ergebnisse ist nur dort möglich. Hier können Sie vor Allem einsehen und markieren, welche Prüfungsleistungen von den zuständigen Prüfungsbeauftragten bereits vollständig bearbeitet wurden. ExamRegisterForOccurrence: Anmeldung zur Klausur erfolgt durch Anmeldung zu einem Termin/Raum diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index cfcd7487b..5a4912769 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -491,7 +491,7 @@ CorrectorsPlaceholder: Correctors... CorrectorsDefaulted: List of correctors was automatically generated based on those of preceding sheets for this course. No data has been saved, yet. Users: Users -HomeHeading: Home +NewsHeading: News LoginHeading: Authentication LoginTitle: Authentication ProfileHeading: Settings @@ -506,9 +506,9 @@ NotificationSettingsHeading displayName: Notification settings for #{displayName TokensLastReset: Tokens last reset TokensResetSuccess: Successfully invalidated all authorisation tokens -HomeOpenAllocations: Active central allocations -HomeUpcomingSheets: Upcoming exercise sheets -HomeUpcomingExams: Upcoming exams +NewsOpenAllocations: Active central allocations +NewsUpcomingSheets: Upcoming exercise sheets +NewsUpcomingExams: Upcoming exams NumCourses num: #{num} #{pluralEN num "course" "courses"} CloseAlert: Close @@ -1113,7 +1113,7 @@ InvalidRoute: Could not interpret url MenuOpenCourses: Courses with open registration MenuOpenAllocations: Active central allocations -MenuHome: Home +MenuNews: News MenuInformation: Information MenuLegal: Legal MenuDataProt: Data protection @@ -1559,7 +1559,6 @@ ExamBonusRule: Bonus points from exercises ExamNoBonus': No automatic exam bonus ExamBonusPoints': Compute from exercise achievements ExamBonusManual': Manual computation -ExamGradesExplanation: This view shows the same data as the table of exam participants. Changing participant's data and achievements is only possible via the table of exam participants. Primarily, this view allows you to check and adjust which exam achievements were properly handled by the relevant exam offices. ExamRegisterForOccurrence: Registration for this exam is done by registering for an occurrence/room diff --git a/routes b/routes index 52f9bad23..535a80677 100644 --- a/routes +++ b/routes @@ -41,7 +41,7 @@ /metrics MetricsR GET -/ HomeR GET !free +/ NewsR GET !free /users UsersR GET POST -- no tags, i.e. admins only /users/#CryptoUUIDUser AdminUserR GET POST /users/#CryptoUUIDUser/delete AdminUserDeleteR POST diff --git a/src/Application.hs b/src/Application.hs index e84ad6bb8..ff1913393 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -101,7 +101,7 @@ import Data.List (cycle) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) -import Handler.Home +import Handler.News import Handler.Info import Handler.Help import Handler.Profile diff --git a/src/Foundation.hs b/src/Foundation.hs index 184cedf7c..126df1e64 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,5 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto module Foundation @@ -63,6 +65,7 @@ import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) +import Control.Monad.Trans.State (execStateT) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4) import qualified Control.Monad.Catch as C @@ -71,14 +74,15 @@ import Handler.Utils.StudyFeatures import Handler.Utils.SchoolLdap import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam -import Handler.Utils.ExamOffice.Course +-- import Handler.Utils.ExamOffice.Course import Handler.Utils.Profile import Handler.Utils.Routes import Utils.Form -import Utils.Sheet +-- import Utils.Sheet import Utils.SystemMessage import Text.Shakespeare.Text (st) +import Text.Cassius (cassiusFile) import Yesod.Form.I18n.German import Yesod.Form.I18n.English @@ -113,64 +117,89 @@ instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX) mr = renderMessage f ls (pieces, _) = renderRoute route +data NavType + = NavTypeLink + { navModal :: Bool + } + | NavTypeButton + { navMethod :: StdMethod + , navData :: [(Text, Text)] + } deriving (Eq, Ord, Read, Show, Generic, Typeable) --- Menus and Favourites -data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary | Footer - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +makeLenses_ ''NavType +makePrisms ''NavType -instance Universe MenuType -instance Finite MenuType +data NavLevel = NavLevelTop | NavLevelInner + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -makePrisms ''MenuType +data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -data MenuItem = MenuItem - { menuItemLabel :: UniWorXMessage - , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery - , menuItemRoute :: SomeRoute UniWorX - , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) - , menuItemModal :: Bool - , menuItemType :: MenuType +data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink + { navLabel :: msg + , navRoute :: route + , navAccess' :: Handler Bool + , navType :: NavType + , navQuick :: Bool + , navForceActive :: Bool } -makeLenses_ ''MenuItem +makeLenses_ ''NavLink -instance RedirectUrl UniWorX MenuItem where - toTextUrl MenuItem{..} = toTextUrl menuItemRoute -instance HasRoute UniWorX MenuItem where - urlRoute MenuItem{..} = urlRoute menuItemRoute +instance HasRoute UniWorX NavLink where + urlRoute NavLink{..} = urlRoute navRoute +instance RedirectUrl UniWorX NavLink where + toTextUrl NavLink{..} = toTextUrl navRoute +instance RenderMessage UniWorX NavLink where + renderMessage app ls NavLink{..} = renderMessage app ls navLabel -menuItemAccessCallback :: MenuItem -> Handler Bool -menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menuItemAccessCallback' +data Nav + = NavHeader + { navHeaderRole :: NavHeaderRole + , navIcon :: Icon + , navLink :: NavLink + } + | NavHeaderContainer + { navHeaderRole :: NavHeaderRole + , navLabel :: SomeMessage UniWorX + , navIcon :: Icon + , navChildren :: [NavLink] + } + | NavPageActionPrimary + { navLink :: NavLink + , navChildren :: [NavLink] + } + | NavPageActionSecondary + { navLink :: NavLink + } + | NavFooter + { navLink :: NavLink + } deriving (Generic, Typeable) + +makeLenses_ ''Nav +makePrisms ''Nav + +data NavChildren +type instance Children NavChildren a = ChildrenNavChildren a +type family ChildrenNavChildren a where + ChildrenNavChildren (SomeMessage UniWorX) = '[] + + ChildrenNavChildren a = Children ChGeneric a + +navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Nav -> MaybeT m Nav +navAccess = execStateT $ do + guardM $ preuse _navLink >>= maybe (return True) navLinkAccess + + _navChildren <~ (filterM navLinkAccess =<< use _navChildren) + whenM (hasn't _navLink <$> use id) $ + guardM $ not . null <$> use _navChildren + +navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => NavLink -> m Bool +navLinkAccess NavLink{..} = liftHandler navAccess' `and2M` accessCheck navType navRoute where - authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized (urlRoute menuItemRoute) False - -$(return []) - - -data instance ButtonClass UniWorX - = BCIsButton - | BCDefault - | BCPrimary - | BCSuccess - | BCInfo - | BCWarning - | BCDanger - | BCLink - | BCMassInputAdd | BCMassInputDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe (ButtonClass UniWorX) -instance Finite (ButtonClass UniWorX) - -instance PathPiece (ButtonClass UniWorX) where - toPathPiece BCIsButton = "btn" - toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass - fromPathPiece = finiteFromPathPiece - - -embedRenderMessage ''UniWorX ''ButtonSubmit id -instance Button UniWorX ButtonSubmit where - btnClasses BtnSubmit = [BCIsButton, BCPrimary] - + accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool + accessCheck nt (urlRoute -> route) = handleAll (\_ -> return False) $ bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route + getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) @@ -186,9 +215,9 @@ appLanguagesOpts :: ( MonadHandler m ) => m (OptionList Lang) -- ^ Authoritive list of supported Languages appLanguagesOpts = do - mr <- getsYesod renderMessage + MsgRenderer mr <- getMsgRenderer let mkOption l = Option - { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l) + { optionDisplay = mr $ MsgLanguage l , optionInternalValue = l , optionExternalValue = l } @@ -1334,6 +1363,30 @@ evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False +data instance ButtonClass UniWorX + = BCIsButton + | BCDefault + | BCPrimary + | BCSuccess + | BCInfo + | BCWarning + | BCDanger + | BCLink + | BCMassInputAdd | BCMassInputDelete + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe (ButtonClass UniWorX) +instance Finite (ButtonClass UniWorX) + +instance PathPiece (ButtonClass UniWorX) where + toPathPiece BCIsButton = "btn" + toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass + fromPathPiece = finiteFromPathPiece + +embedRenderMessage ''UniWorX ''ButtonSubmit id +instance Button UniWorX ButtonSubmit where + btnClasses BtnSubmit = [BCIsButton, BCPrimary] + + updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate -> ReaderT SqlBackend m () @@ -1507,16 +1560,16 @@ instance Yesod UniWorX where makeLogger = readTVarIO . snd . appLogger -langForm :: Form (Lang, Route UniWorX) -langForm csrf = do - lang <- selectLanguage appLanguages - route <- getCurrentRoute - (urlRes, urlView) <- mreq hiddenField ("" & addName ("referer" :: Text)) route - (langBoxRes, langBoxView) <- mreq - (selectField appLanguagesOpts) - ("" & addAttr "multiple" "multiple" & addAttr "size" (tshow . min 10 $ length appLanguages) & addAutosubmit & addName ("lang" :: Text)) - (Just lang) - return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView) +-- langForm :: Form (Lang, Route UniWorX) +-- langForm csrf = do +-- lang <- selectLanguage appLanguages +-- route <- getCurrentRoute +-- (urlRes, urlView) <- mreq hiddenField ("" & addName ("referer" :: Text)) route +-- (langBoxRes, langBoxView) <- mreq +-- (selectField appLanguagesOpts) +-- ("" & addAttr "multiple" "multiple" & addAttr "size" (tshow . min 10 $ length appLanguages) & addAutosubmit & addName ("lang" :: Text)) +-- (Just lang) +-- return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView) siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html siteLayoutMsg msg widget = do @@ -1563,12 +1616,6 @@ siteLayout' headingOverride widget = do -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) - defaultLinks' <- defaultLinks - let menu :: [MenuItem] - menu = defaultLinks' ++ maybe [] pageActions mcurrentRoute - - menuTypes <- mapM (\x -> (,,) <$> pure x <*> newIdent <*> toTextUrl x) =<< filterM menuItemAccessCallback menu - isAuth <- isJust <$> maybeAuthId -- Lookup Favourites & Theme if possible @@ -1623,9 +1670,18 @@ siteLayout' headingOverride widget = do -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite in do - items <- filterM menuItemAccessCallback (pageActions courseRoute) - items' <- forM items $ \i -> (i, ) <$> toTextUrl i - return (c, courseRoute, items', favouriteReason) + items''' <- pageActions courseRoute + items'' <- catMaybes <$> mapM (runMaybeT . navAccess) items''' + items' <- filterM navLinkAccess $ items'' ^.. typesUsing @NavChildren @NavLink . filtered navQuick + items <- forM items' $ \n -> (n,) <$> toTextUrl n + return (c, courseRoute, items, favouriteReason) + + nav'' <- mconcat <$> sequence + [ defaultLinks + , maybe (return []) pageActions mcurrentRoute + ] + nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' + nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren) mmsgs <- if | isModal -> getMessages @@ -1636,21 +1692,23 @@ siteLayout' headingOverride widget = do \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages - (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm - let langFormView' = wrapForm langFormView def - { formAction = Just $ SomeRoute LangR - , formSubmit = FormAutoSubmit - , formEncoding = langFormEnctype - } + -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm + -- let langFormView' = wrapForm langFormView def + -- { formAction = Just $ SomeRoute LangR + -- , formSubmit = FormAutoSubmit + -- , formEncoding = langFormEnctype + -- } - let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority - highlight = let crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents - navItems = map (view _2) favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes - highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs - in \r -> Just r == highR + let highlight :: HasRoute UniWorX url => url -> Bool + -- ^ highlight last route in breadcrumbs, favorites taking priority + highlight = (highR ==) . Just . urlRoute + where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents + navItems = map (view _2) favourites ++ toListOf (folded . _1 . _navLink . to urlRoute) nav + highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs + highlightNav = (||) <$> navForceActive <*> highlight favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites - favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(MenuItem, Text)], FavouriteReason)] + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(NavLink, Text)], FavouriteReason)] favouriteTermReason tid favReason' = favourites & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason') & sortOn (\(Course{..}, _, _, _) -> courseName) @@ -1661,24 +1719,89 @@ siteLayout' headingOverride widget = do -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. - navbarModal (MenuItem{..}, menuIdent') = customModal Modal - { modalTriggerId = Just menuIdent' - , modalId = Nothing - , modalTrigger = \(Just route) menuIdent -> $(widgetFile "widgets/navbar/item") - , modalContent = Left menuItemRoute - } + navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> Widget + navWidget (n, navIdent, navRoute', _navChildren') = case n of + NavHeader{ navLink = navLink@NavLink{..}, .. } + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/item") + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/navbar/item") + NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. } + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/primary") + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/pageaction/primary") + NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. } + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/secondary") + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/pageaction/secondary") + NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container") + _other -> error "not implemented" - navbarItem (MenuItem{..}, menuIdent) = do - route <- toTextUrl menuItemRoute - $(widgetFile "widgets/navbar/item") + navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) + -> (NavLink, Text, Text) + -> Widget + navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of + NavHeaderContainer{} + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just iNavIdent + , modalId = Nothing + , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/navbar-container-item--link") + , modalContent = Left $ SomeRoute iN + } + | NavTypeLink{} <- navType + -> let route = iNavRoute + ident = iNavIdent + in $(widgetFile "widgets/navbar/navbar-container-item--link") + | NavTypeButton{..} <- navType -> do + csrfToken <- reqToken <$> getRequest + wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def + { formMethod = navMethod + , formSubmit = FormNoSubmit + , formAction = Just $ SomeRoute iN + } + _other -> error "not implemented" navbar :: Widget - navbar = $(widgetFile "widgets/navbar/navbar") + navbar = do + $(widgetFile "widgets/navbar/navbar") + forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) -> + toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius") + where isNavHeaderPrimary = has $ _1 . _navHeaderRole . only NavHeaderPrimary + isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav/asidenav") where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") footer :: Widget footer = $(widgetFile "widgets/footer/footer") + where isNavFooter = has $ _1 . _NavFooter alerts :: Widget alerts = $(widgetFile "widgets/alerts/alerts") contentHeadline :: Maybe Widget @@ -1690,11 +1813,13 @@ siteLayout' headingOverride widget = do -- functions to determine if there are page-actions (primary or secondary) hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions - hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes - hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes + hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav + hasPrimaryPageActions = has (folded . _1 . _NavPageActionPrimary ) nav contentRibbon :: Maybe Widget contentRibbon = fmap toWidget appRibbon + isNavHeaderContainer = has $ _1 . _NavHeaderContainer + MsgRenderer mr <- getMsgRenderer let -- See Utils.Frontend.I18n and files in messages/frontend for message definitions @@ -1753,12 +1878,12 @@ i18nCrumb msg mbR = do -- i.e. information might be leaked by not performing permission checks if the -- breadcrumb value depends on sensitive content (like an user's name). instance YesodBreadcrumbs UniWorX where - breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just HomeR + breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing - breadcrumb HomeR = i18nCrumb MsgMenuHome Nothing + breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do @@ -1821,7 +1946,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR - breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just HomeR + breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid @@ -1835,7 +1960,7 @@ instance YesodBreadcrumbs UniWorX where <*> fmap isJust (get tid) return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) - breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just HomeR + breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR breadcrumb (AllocationR tid ssh ash AShowR) = maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do mr <- getMessageRender Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash @@ -1989,7 +2114,7 @@ instance YesodBreadcrumbs UniWorX where mayList <- (== Authorized) <$> evalAccess MessageListR False if | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR - | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just HomeR + | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR @@ -2030,1202 +2155,1224 @@ submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` shee -defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [MenuItem] +defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [Nav] defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. - [ return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuHome - , menuItemIcon = Just "home" - , menuItemRoute = SomeRoute HomeR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuDataProt - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ LegalR :#: ("data-protection" :: Text) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuTermsUse - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ LegalR :#: ("terms-of-use" :: Text) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuCopyright - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ LegalR :#: ("copyright" :: Text) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuImprint - , menuItemIcon = Just "file-signature" - , menuItemRoute = SomeRoute $ LegalR :#: ("imprint" :: Text) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuInformation - , menuItemIcon = Just "info" - , menuItemRoute = SomeRoute InfoR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuGlossary - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute GlossaryR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , do + [ do mCurrentRoute <- getCurrentRoute - return MenuItem - { menuItemType = NavbarRight - , menuItemLabel = MsgMenuHelp - , menuItemIcon = Just "question" - , menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute]) - , menuItemModal = True - , menuItemAccessCallback' = return True + activeLang <- selectLanguage appLanguages + + let navChildren = flip map (toList appLanguages) $ \lang -> NavLink + { navLabel = MsgLanguage lang + , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ]) + , navAccess' = return True + , navType = NavTypeButton + { navMethod = POST + , navData = [(toPathPiece PostLanguage, lang)] + } + , navQuick = False + , navForceActive = lang == activeLang + } + + guard $ length navChildren > 1 + + return NavHeaderContainer + { navHeaderRole = NavHeaderSecondary + , navLabel = SomeMessage MsgMenuLanguage + , navIcon = IconLanguage + , navChildren } - , return MenuItem - { menuItemType = NavbarRight - , menuItemLabel = MsgMenuProfile - , menuItemIcon = Just "cogs" - , menuItemRoute = SomeRoute ProfileR - , menuItemModal = False - , menuItemAccessCallback' = isJust <$> maybeAuthPair - } - , return MenuItem - { menuItemType = NavbarSecondary - , menuItemLabel = MsgMenuLogin - , menuItemIcon = Just "sign-in-alt" - , menuItemRoute = SomeRoute $ AuthR LoginR - , menuItemModal = True - , menuItemAccessCallback' = isNothing <$> maybeAuthPair - } - , return MenuItem - { menuItemType = NavbarSecondary - , menuItemLabel = MsgMenuLogout - , menuItemIcon = Just "sign-out-alt" - , menuItemRoute = SomeRoute $ AuthR LogoutR - , menuItemModal = False - , menuItemAccessCallback' = isJust <$> maybeAuthPair - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuTermShow - , menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!! - , menuItemRoute = SomeRoute TermShowR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuCourseList - , menuItemIcon = Just "graduation-cap" - , menuItemRoute = SomeRoute CourseListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuCorrections - , menuItemIcon = Just "check" - , menuItemRoute = SomeRoute CorrectionsR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuExamOfficeExams - , menuItemIcon = Just "poll-h" - , menuItemRoute = SomeRoute $ ExamOfficeR EOExamsR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuUsers - , menuItemIcon = Just "users" - , menuItemRoute = SomeRoute UsersR - , menuItemModal = False - , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False - } - , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgAdminHeading - , menuItemIcon = Just "screwdriver" - , menuItemRoute = SomeRoute AdminR - , menuItemModal = False - , menuItemAccessCallback' = return True - } ] + -- [ return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuNews + -- , menuItemIcon = Just "home" + -- , menuItemRoute = SomeRoute NewsR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuDataProt + -- , menuItemIcon = Nothing + -- , menuItemRoute = SomeRoute $ LegalR :#: ("data-protection" :: Text) + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuTermsUse + -- , menuItemIcon = Nothing + -- , menuItemRoute = SomeRoute $ LegalR :#: ("terms-of-use" :: Text) + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuCopyright + -- , menuItemIcon = Nothing + -- , menuItemRoute = SomeRoute $ LegalR :#: ("copyright" :: Text) + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuImprint + -- , menuItemIcon = Just "file-signature" + -- , menuItemRoute = SomeRoute $ LegalR :#: ("imprint" :: Text) + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuInformation + -- , menuItemIcon = Just "info" + -- , menuItemRoute = SomeRoute InfoR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = Footer + -- , menuItemLabel = MsgMenuGlossary + -- , menuItemIcon = Nothing + -- , menuItemRoute = SomeRoute GlossaryR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , do + -- mCurrentRoute <- getCurrentRoute + + -- return MenuItem + -- { menuItemType = NavbarRight + -- , menuItemLabel = MsgMenuHelp + -- , menuItemIcon = Just "question" + -- , menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute]) + -- , menuItemModal = True + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = NavbarRight + -- , menuItemLabel = MsgMenuProfile + -- , menuItemIcon = Just "cogs" + -- , menuItemRoute = SomeRoute ProfileR + -- , menuItemModal = False + -- , menuItemAccessCallback' = isJust <$> maybeAuthPair + -- } + -- , return MenuItem + -- { menuItemType = NavbarSecondary + -- , menuItemLabel = MsgMenuLogin + -- , menuItemIcon = Just "sign-in-alt" + -- , menuItemRoute = SomeRoute $ AuthR LoginR + -- , menuItemModal = True + -- , menuItemAccessCallback' = isNothing <$> maybeAuthPair + -- } + -- , return MenuItem + -- { menuItemType = NavbarSecondary + -- , menuItemLabel = MsgMenuLogout + -- , menuItemIcon = Just "sign-out-alt" + -- , menuItemRoute = SomeRoute $ AuthR LogoutR + -- , menuItemModal = False + -- , menuItemAccessCallback' = isJust <$> maybeAuthPair + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuTermShow + -- , menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!! + -- , menuItemRoute = SomeRoute TermShowR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuCourseList + -- , menuItemIcon = Just "graduation-cap" + -- , menuItemRoute = SomeRoute CourseListR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuCorrections + -- , menuItemIcon = Just "check" + -- , menuItemRoute = SomeRoute CorrectionsR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuExamOfficeExams + -- , menuItemIcon = Just "poll-h" + -- , menuItemRoute = SomeRoute $ ExamOfficeR EOExamsR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgMenuUsers + -- , menuItemIcon = Just "users" + -- , menuItemRoute = SomeRoute UsersR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + -- } + -- , return MenuItem + -- { menuItemType = NavbarAside + -- , menuItemLabel = MsgAdminHeading + -- , menuItemIcon = Just "screwdriver" + -- , menuItemRoute = SomeRoute AdminR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + -- ] -pageActions :: Route UniWorX -> [MenuItem] -{- - Icons: https://fontawesome.com/icons?d=gallery - Guideline: use icons without boxes/frames, only non-pro - - Please keep sorted according to routes --} -pageActions (HomeR) = - [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgInfoLecturerTitle - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InfoLecturerR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseNew - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute CourseNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuExternalExamList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute EExamListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuOpenCourses - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CourseListR, [("courses-openregistration", "True")]) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuOpenAllocations - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (AllocationListR, [("allocations-active", "True")]) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (AdminR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSchoolList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute SchoolListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgAdminFeaturesHeading - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminFeaturesR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuMessageList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute MessageListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuAdminErrMsg - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminErrMsgR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuAdminTest - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminTestR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (ExamOfficeR EOExamsR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamOfficeFields - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ ExamOfficeR EOFieldsR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamOfficeUsers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ ExamOfficeR EOUsersR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - ] -pageActions (SchoolListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSchoolNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute SchoolNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (UsersR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuLecturerInvite - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuUserAdd - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminUserAddR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - ] -pageActions (AdminUserR cID) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuUserNotifications - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ UserNotificationR cID - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuUserPassword - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ UserPasswordR cID - , menuItemModal = True - , menuItemAccessCallback' = do - uid <- decrypt cID - User{userAuthentication} <- runDB $ get404 uid - return $ is _AuthPWHash userAuthentication - } - ] -pageActions (InfoR) = [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgInfoLecturerTitle - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InfoLecturerR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuLegal - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute LegalR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuGlossary - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute GlossaryR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (VersionR) = [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgInfoLecturerTitle - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InfoLecturerR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions HealthR = [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuInstance - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InstanceR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions InstanceR = [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuHealth - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute HealthR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (HelpR) = [ - -- MenuItem - -- { menuItemType = PageActionPrime - -- , menuItemLabel = MsgInfoLecturerTitle - -- , menuItemIcon = Nothing - -- , menuItemRoute = SomeRoute InfoLecturerR - -- , menuItemModal = False - -- , menuItemAccessCallback' = return True - -- } - ] -pageActions (ProfileR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuProfileData - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute ProfileDataR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuAuthPreds - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AuthPredsR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - ] -pageActions TermShowR = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTermCreate - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute TermEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuParticipantsList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute ParticipantsListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (TermCourseListR tid) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseNew - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute CourseNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTermEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ TermEditExistR tid - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (TermSchoolCourseListR _tid _ssh) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseNew - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute CourseNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (AllocationR _tid _ssh _ash AShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuAllocationInfo - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InfoAllocationR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseNew - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute CourseNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuAllocationList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AllocationListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuParticipantsList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute ParticipantsListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseNewR) = [ - MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgInfoLecturerTitle - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute InfoLecturerR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh CShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuMaterialList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR - , menuItemModal = False - , menuItemAccessCallback' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material - materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents - existsVisible = do - matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do - E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse - 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 - return $ material E.^. MaterialName - anyM matNames (materialAccess . E.unValue) - in runDB $ lecturerAccess `or2M` existsVisible - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR - , menuItemModal = False - , menuItemAccessCallback' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets - sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents - existsVisible = do - sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - 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 - return $ sheet E.^. SheetName - anyM sheetNames $ sheetAccess . E.unValue - in runDB $ lecturerAccess `or2M` existsVisible - } - ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTutorialList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamList - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR - , menuItemModal = False - , menuItemAccessCallback' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR - examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR - existsVisible = do - examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - 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 - return $ exam E.^. ExamName - anyM examNames $ examAccess . E.unValue - in runDB $ lecturerAccess `or2M` existsVisible - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseApplications - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR - , menuItemModal = False - , menuItemAccessCallback' = - let courseWhere course = 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 - existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - void $ courseWhere course - courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do - void $ courseWhere course - return $ course E.^. CourseApplicationsRequired - courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - void $ courseWhere course - in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseMembers - , menuItemIcon = Just "user-graduate" - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR - , menuItemModal = False - , menuItemAccessCallback' = do - now <- liftIO getCurrentTime - let courseWhere course = 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 - hasActiveAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation) -> do - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId - void $ courseWhere course - E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) - E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse) - hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - void $ courseWhere course - runDB $ (not <$> hasActiveAllocation) `or2M` hasParticipants - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseCommunication - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseClone - , menuItemIcon = Just "copy" - , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseDelete - , menuItemIcon = Just "trash" - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseExamOffice - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamOfficeR - , menuItemModal = True - , menuItemAccessCallback' = do - uid <- requireAuthId - runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - E.selectExists $ do - (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) - E.where_ $ E.not_ isForced - } - ] -pageActions (CourseR tid ssh csh CCorrectionsR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh SheetListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetCurrent - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR - , menuItemModal = False - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - void . MaybeT $ sheetCurrent tid ssh csh - return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetOldUnassigned - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR - , menuItemModal = False - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - void . MaybeT $ sheetOldUnassigned tid ssh csh - return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) - ]) - , menuItemModal = False - , menuItemAccessCallback' = do - muid <- maybeAuthId - case muid of - Nothing -> return False - (Just uid) -> do - ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return ok - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh CUsersR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseAddMembers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseApplications - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR - , menuItemModal = False - , menuItemAccessCallback' = - let courseWhere course = 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 - existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - void $ courseWhere course - courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do - void $ courseWhere course - return $ course E.^. CourseApplicationsRequired - courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - void $ courseWhere course - in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications - } - ] -pageActions (CourseR tid ssh csh MaterialListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuMaterialNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CMaterialR tid ssh csh mnm MShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuMaterialEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuMaterialDelete - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh CTutorialListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTutorialNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CTutorialR tid ssh csh tutn TEditR) = - [ MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuTutorialDelete - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CTutorialR tid ssh csh tutn TUsersR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTutorialComm - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TCommR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuTutorialEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuTutorialDelete - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh CExamListR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CExamR tid ssh csh examn EShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamUsers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamGrades - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CExamR tid ssh csh examn EUsersR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamAddMembers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamGrades - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CExamR tid ssh csh examn EGradesR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExamUsers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CSheetR tid ssh csh shn SShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissionNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR - , menuItemModal = True - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard $ null submissions - return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissionOwn - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR - , menuItemModal = False - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard . not $ null submissions - return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) - , ("corrections-sheet" , CI.original shn) - ]) - , menuItemModal = False - , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSheetEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuSheetClone - , menuItemIcon = Just "copy" - , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuSheetDelete - , menuItemIcon = Just "trash" - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CSheetR tid ssh csh shn SSubsR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuSubmissionNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrection - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgCorrectorAssignTitle - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuSubmissionDelete - , menuItemIcon = Just "trash" - , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = - [ MenuItem - { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuSubmissionDelete - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CourseR tid ssh csh CApplicationsR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseApplicationsFiles - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR - , menuItemModal = False - , menuItemAccessCallback' - = let appAccess (E.Value appId) = do - cID <- encrypt appId - hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR - appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - 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.where_ . E.exists . E.from $ \courseApplicationFile -> - E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId - return $ courseApplication E.^. CourseApplicationId - in runDB . runConduit $ appSource .| anyMC appAccess - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCourseMembers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR - , menuItemModal = False - , menuItemAccessCallback' = runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - exists [ CourseParticipantCourse ==. cid ] - } - ] -pageActions (CorrectionsR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsDownload - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsDownloadR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsUpload - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsUploadR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsCreate - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsCreateR - , menuItemModal = False - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - let - isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ - $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid - E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - isLecturer = E.exists . E.from $ \lecturer -> E.where_ - $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ isCorrector' E.||. isLecturer - return $ sheet E.^. SheetSubmissionMode - return $ orOf (traverse . _Value . _submissionModeCorrector) sheets - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsGrade - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsGradeR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (CorrectionsGradeR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsUpload - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsUploadR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsCreate - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CorrectionsCreateR - , menuItemModal = False - , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - let - isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ - $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid - E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - isLecturer = E.exists . E.from $ \lecturer -> E.where_ - $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ isCorrector' E.||. isLecturer - return $ sheet E.^. SheetSubmissionMode - return $ orOf (traverse . _Value . _submissionModeCorrector) sheets - } - ] -pageActions EExamListR = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamNew - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute EExamNewR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (EExamR tid ssh coursen examn EEShowR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamEdit - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEEditR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamUsers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamGrades - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (EExamR tid ssh coursen examn EEGradesR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamUsers - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions (EExamR tid ssh coursen examn EEUsersR) = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuExternalExamGrades - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - ] -pageActions ParticipantsListR = - [ MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgCsvOptions - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute CsvOptionsR - , menuItemModal = True - , menuItemAccessCallback' = return True - } - ] -pageActions _ = [] +-- pageActions :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m [Nav] +pageActions :: _ +pageActions _ = return [] +-- pageActions (NewsR) = +-- [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgInfoLecturerTitle +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InfoLecturerR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseNew +-- , menuItemIcon = Just "book" +-- , menuItemRoute = SomeRoute CourseNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuExternalExamList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute EExamListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuOpenCourses +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute (CourseListR, [("courses-openregistration", "True")]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuOpenAllocations +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute (AllocationListR, [("allocations-active", "True")]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (AdminR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSchoolList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute SchoolListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgAdminFeaturesHeading +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AdminFeaturesR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuMessageList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute MessageListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuAdminErrMsg +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AdminErrMsgR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuAdminTest +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AdminTestR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (ExamOfficeR EOExamsR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamOfficeFields +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ ExamOfficeR EOFieldsR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamOfficeUsers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ ExamOfficeR EOUsersR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (SchoolListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSchoolNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute SchoolNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (UsersR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuLecturerInvite +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuUserAdd +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AdminUserAddR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (AdminUserR cID) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuUserNotifications +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ UserNotificationR cID +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuUserPassword +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ UserPasswordR cID +-- , menuItemModal = True +-- , menuItemAccessCallback' = do +-- uid <- decrypt cID +-- User{userAuthentication} <- runDB $ get404 uid +-- return $ is _AuthPWHash userAuthentication +-- } +-- ] +-- pageActions (InfoR) = [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgInfoLecturerTitle +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InfoLecturerR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuLegal +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute LegalR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuGlossary +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute GlossaryR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (VersionR) = [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgInfoLecturerTitle +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InfoLecturerR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions HealthR = [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuInstance +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InstanceR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions InstanceR = [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuHealth +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute HealthR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (HelpR) = [ +-- -- MenuItem +-- -- { menuItemType = PageActionPrime +-- -- , menuItemLabel = MsgInfoLecturerTitle +-- -- , menuItemIcon = Nothing +-- -- , menuItemRoute = SomeRoute InfoLecturerR +-- -- , menuItemModal = False +-- -- , menuItemAccessCallback' = return True +-- -- } +-- ] +-- pageActions (ProfileR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuProfileData +-- , menuItemIcon = Just "book" +-- , menuItemRoute = SomeRoute ProfileDataR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuAuthPreds +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AuthPredsR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions TermShowR = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTermCreate +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute TermEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuParticipantsList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute ParticipantsListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (TermCourseListR tid) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseNew +-- , menuItemIcon = Just "book" +-- , menuItemRoute = SomeRoute CourseNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTermEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ TermEditExistR tid +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (TermSchoolCourseListR _tid _ssh) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseNew +-- , menuItemIcon = Just "book" +-- , menuItemRoute = SomeRoute CourseNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (AllocationR _tid _ssh _ash AShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuAllocationInfo +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InfoAllocationR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseNew +-- , menuItemIcon = Just "book" +-- , menuItemRoute = SomeRoute CourseNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuAllocationList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute AllocationListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuParticipantsList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute ParticipantsListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseNewR) = [ +-- MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgInfoLecturerTitle +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute InfoLecturerR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh CShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuMaterialList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = +-- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material +-- materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents +-- existsVisible = do +-- matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do +-- E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse +-- 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 +-- return $ material E.^. MaterialName +-- anyM matNames (materialAccess . E.unValue) +-- in runDB $ lecturerAccess `or2M` existsVisible +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSheetList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = +-- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets +-- sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents +-- existsVisible = do +-- sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do +-- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse +-- 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 +-- return $ sheet E.^. SheetName +-- anyM sheetNames $ sheetAccess . E.unValue +-- in runDB $ lecturerAccess `or2M` existsVisible +-- } +-- ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTutorialList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamList +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR +-- , menuItemModal = False +-- , menuItemAccessCallback' = +-- let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR +-- examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR +-- existsVisible = do +-- examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do +-- E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse +-- 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 +-- return $ exam E.^. ExamName +-- anyM examNames $ examAccess . E.unValue +-- in runDB $ lecturerAccess `or2M` existsVisible +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseApplications +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR +-- , menuItemModal = False +-- , menuItemAccessCallback' = +-- let courseWhere course = 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 +-- existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do +-- E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse +-- void $ courseWhere course +-- courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do +-- void $ courseWhere course +-- return $ course E.^. CourseApplicationsRequired +-- courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do +-- E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse +-- void $ courseWhere course +-- in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseMembers +-- , menuItemIcon = Just "user-graduate" +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = do +-- now <- liftIO getCurrentTime +-- let courseWhere course = 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 +-- hasActiveAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation) -> do +-- E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation +-- E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId +-- void $ courseWhere course +-- E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) +-- E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse) +-- hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do +-- E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse +-- void $ courseWhere course +-- runDB $ (not <$> hasActiveAllocation) `or2M` hasParticipants +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseCommunication +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseClone +-- , menuItemIcon = Just "copy" +-- , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseDelete +-- , menuItemIcon = Just "trash" +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuCourseExamOffice +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamOfficeR +-- , menuItemModal = True +-- , menuItemAccessCallback' = do +-- uid <- requireAuthId +-- runDB $ do +-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh +-- E.selectExists $ do +-- (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) +-- E.where_ $ E.not_ isForced +-- } +-- ] +-- pageActions (CourseR tid ssh csh CCorrectionsR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsAssign +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh SheetListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSheetCurrent +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- void . MaybeT $ sheetCurrent tid ssh csh +-- return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSheetOldUnassigned +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- void . MaybeT $ sheetOldUnassigned tid ssh csh +-- return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSubmissions +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsAssign +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsOwn +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) +-- , ("corrections-school", CI.original $ unSchoolKey ssh) +-- , ("corrections-course", CI.original csh) +-- ]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = do +-- muid <- maybeAuthId +-- case muid of +-- Nothing -> return False +-- (Just uid) -> do +-- ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do +-- E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId +-- E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId +-- E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) +-- E.&&. course E.^. CourseTerm E.==. E.val tid +-- E.&&. course E.^. CourseSchool E.==. E.val ssh +-- E.&&. course E.^. CourseShorthand E.==. E.val csh +-- return ok +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSheetNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh CUsersR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseAddMembers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseApplications +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR +-- , menuItemModal = False +-- , menuItemAccessCallback' = +-- let courseWhere course = 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 +-- existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do +-- E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse +-- void $ courseWhere course +-- courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do +-- void $ courseWhere course +-- return $ course E.^. CourseApplicationsRequired +-- courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do +-- E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse +-- void $ courseWhere course +-- in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications +-- } +-- ] +-- pageActions (CourseR tid ssh csh MaterialListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuMaterialNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CMaterialR tid ssh csh mnm MShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuMaterialEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuMaterialDelete +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh CTutorialListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTutorialNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CTutorialR tid ssh csh tutn TEditR) = +-- [ MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuTutorialDelete +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CTutorialR tid ssh csh tutn TUsersR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTutorialComm +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TCommR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuTutorialEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuTutorialDelete +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh CExamListR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CExamR tid ssh csh examn EShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamUsers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamGrades +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CExamR tid ssh csh examn EUsersR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamAddMembers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamGrades +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CExamR tid ssh csh examn EGradesR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExamUsers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CSheetR tid ssh csh shn SShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSubmissionNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR +-- , menuItemModal = True +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- uid <- MaybeT $ liftHandler maybeAuthId +-- submissions <- lift $ submissionList tid csh shn uid +-- guard $ null submissions +-- return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSubmissionOwn +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- uid <- MaybeT $ liftHandler maybeAuthId +-- submissions <- lift $ submissionList tid csh shn uid +-- guard . not $ null submissions +-- return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsOwn +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) +-- , ("corrections-school", CI.original $ unSchoolKey ssh) +-- , ("corrections-course", CI.original csh) +-- , ("corrections-sheet" , CI.original shn) +-- ]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSubmissions +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsAssign +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSheetEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuSheetClone +-- , menuItemIcon = Just "copy" +-- , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuSheetDelete +-- , menuItemIcon = Just "trash" +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CSheetR tid ssh csh shn SSubsR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuSubmissionNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsAssign +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrection +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgCorrectorAssignTitle +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuSubmissionDelete +-- , menuItemIcon = Just "trash" +-- , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = +-- [ MenuItem +-- { menuItemType = PageActionSecondary +-- , menuItemLabel = MsgMenuSubmissionDelete +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CourseR tid ssh csh CApplicationsR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseApplicationsFiles +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR +-- , menuItemModal = False +-- , menuItemAccessCallback' +-- = let appAccess (E.Value appId) = do +-- cID <- encrypt appId +-- hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR +-- appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do +-- E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse +-- 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.where_ . E.exists . E.from $ \courseApplicationFile -> +-- E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId +-- return $ courseApplication E.^. CourseApplicationId +-- in runDB . runConduit $ appSource .| anyMC appAccess +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCourseMembers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB $ do +-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh +-- exists [ CourseParticipantCourse ==. cid ] +-- } +-- ] +-- pageActions (CorrectionsR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsDownload +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsDownloadR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsUpload +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsUploadR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsCreate +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsCreateR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- uid <- MaybeT $ liftHandler maybeAuthId +-- sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do +-- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse +-- let +-- isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ +-- $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid +-- E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId +-- isLecturer = E.exists . E.from $ \lecturer -> E.where_ +-- $ lecturer E.^. LecturerUser E.==. E.val uid +-- E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId +-- E.where_ $ isCorrector' E.||. isLecturer +-- return $ sheet E.^. SheetSubmissionMode +-- return $ orOf (traverse . _Value . _submissionModeCorrector) sheets +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsGrade +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsGradeR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (CorrectionsGradeR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsUpload +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsUploadR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuCorrectionsCreate +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CorrectionsCreateR +-- , menuItemModal = False +-- , menuItemAccessCallback' = runDB . maybeT (return False) $ do +-- uid <- MaybeT $ liftHandler maybeAuthId +-- sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do +-- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse +-- let +-- isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ +-- $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid +-- E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId +-- isLecturer = E.exists . E.from $ \lecturer -> E.where_ +-- $ lecturer E.^. LecturerUser E.==. E.val uid +-- E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId +-- E.where_ $ isCorrector' E.||. isLecturer +-- return $ sheet E.^. SheetSubmissionMode +-- return $ orOf (traverse . _Value . _submissionModeCorrector) sheets +-- } +-- ] +-- pageActions EExamListR = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamNew +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute EExamNewR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (EExamR tid ssh coursen examn EEShowR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamEdit +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEEditR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamUsers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- , MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamGrades +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (EExamR tid ssh coursen examn EEGradesR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamUsers +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEUsersR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions (EExamR tid ssh coursen examn EEUsersR) = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgMenuExternalExamGrades +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute $ EExamR tid ssh coursen examn EEGradesR +-- , menuItemModal = False +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions ParticipantsListR = +-- [ MenuItem +-- { menuItemType = PageActionPrime +-- , menuItemLabel = MsgCsvOptions +-- , menuItemIcon = Nothing +-- , menuItemRoute = SomeRoute CsvOptionsR +-- , menuItemModal = True +-- , menuItemAccessCallback' = return True +-- } +-- ] +-- pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () @@ -3235,8 +3382,8 @@ i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg pageHeading :: Route UniWorX -> Maybe Widget pageHeading (AuthR _) = Just $ i18nHeading MsgLoginHeading -pageHeading HomeR - = Just $ i18nHeading MsgHomeHeading +pageHeading NewsR + = Just $ i18nHeading MsgNewsHeading pageHeading UsersR = Just $ i18nHeading MsgUsers pageHeading (AdminUserR _) @@ -3862,9 +4009,9 @@ instance YesodAuth UniWorX where type AuthId UniWorX = UserId -- Where to send a user after successful login - loginDest _ = HomeR + loginDest _ = NewsR -- Where to send a user after logout - logoutDest _ = HomeR + logoutDest _ = NewsR -- Override the above two destinations when a Referer: header is present redirectToReferer _ = True diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 99406decd..028be1e3a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -168,7 +168,7 @@ instance RenderMessage UniWorX MsgLanguage where | ("en" : _) <- lang' = mr MsgEnglish | otherwise = lang where - mr = renderMessage foundation ls + mr = renderMessage foundation $ lang : filter (/= lang) ls embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index eee9a53b0..2d82115c7 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -1089,5 +1089,6 @@ postEUsersR tid ssh csh examn = do siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading - let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip") + let computedValuesTip = notificationWidget NotificationBroad Warning + $(i18nWidgetFile "exam-users/computed-values-tip") $(widgetFile "exam-users") diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index fbb18a591..c92ec1e62 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -441,4 +441,5 @@ postEGradesR tid ssh csh examn = do siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading + let examGradesExplanation = notificationWidget NotificationBroad Info $(i18nWidgetFile "exam-office/exam-grades-explanation") $(widgetFile "exam-office/exam-results") diff --git a/src/Handler/ExamOffice/ExternalExam.hs b/src/Handler/ExamOffice/ExternalExam.hs index 2d7978fbc..db65d9c8c 100644 --- a/src/Handler/ExamOffice/ExternalExam.hs +++ b/src/Handler/ExamOffice/ExternalExam.hs @@ -30,4 +30,5 @@ postEEGradesR tid ssh coursen examn = do siteLayoutMsg (MsgExternalExamGrades coursen examn) $ do setTitleI MsgBreadcrumbExternalExamGrades + let examGradesExplanation = notificationWidget NotificationBroad Info $(i18nWidgetFile "exam-office/exam-grades-explanation") $(widgetFile "exam-office/externalExamGrades") diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index fd03b912b..ab5588677 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -80,7 +80,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} return res invitationSuccessMsg _ _ = return $ SomeMessage MsgExamOfficeUserInvitationAccepted - invitationUltDest _ _ = return $ SomeRoute HomeR + invitationUltDest _ _ = return $ SomeRoute NewsR makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId)) diff --git a/src/Handler/Home.hs b/src/Handler/News.hs similarity index 96% rename from src/Handler/Home.hs rename to src/Handler/News.hs index 532326ec3..e5eab1715 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/News.hs @@ -1,4 +1,4 @@ -module Handler.Home where +module Handler.News where import Import @@ -9,21 +9,25 @@ import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -getHomeR :: Handler Html -getHomeR = do +getNewsR :: Handler Html +getNewsR = do muid <- maybeAuthId defaultLayout $ do - setTitleI MsgHomeHeading + setTitleI MsgNewsHeading + + when (is _Nothing muid) $ + notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch") + case muid of Just uid -> do - homeUpcomingExams uid - homeUpcomingSheets uid + newsUpcomingExams uid + newsUpcomingSheets uid Nothing -> - $(i18nWidgetFile "unauth-home") + $(i18nWidgetFile "unauth-news") -homeUpcomingSheets :: UserId -> Widget -homeUpcomingSheets uid = do +newsUpcomingSheets :: UserId -> Widget +newsUpcomingSheets uid = do cTime <- liftIO getCurrentTime let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) @@ -121,11 +125,11 @@ homeUpcomingSheets uid = do , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } - $(widgetFile "home/upcomingSheets") + $(widgetFile "news/upcomingSheets") -homeUpcomingExams :: UserId -> Widget -homeUpcomingExams uid = do +newsUpcomingExams :: UserId -> Widget +newsUpcomingExams uid = do now <- liftIO getCurrentTime ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do User {userWarningDays} <- get404 uid @@ -255,6 +259,6 @@ homeUpcomingExams uid = do (, userWarningDays) <$> dbTable examDBTableValidator examDBTable - $(widgetFile "home/upcomingExams") + $(widgetFile "news/upcomingExams") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index c13c3f13f..b34ce9cb2 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -850,17 +850,14 @@ postCsvOptionsR = do , formAttrs = [ asyncSubmitAttr | isModal ] } -postLangR :: Handler () +postLangR :: Handler Void postLangR = do - ((langRes, _), _) <- runFormPost $ identifyForm FIDLanguage langForm + requestedLang <- selectLanguage' appLanguages . hoistMaybe <$> lookupGlobalPostParam PostLanguage + lang' <- runDB . updateUserLanguage $ Just requestedLang - formResult langRes $ \(lang, route) -> do - lang' <- runDB . updateUserLanguage $ Just lang - - app <- getYesod - let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang'' - | otherwise = renderMessage app [] - addMessage Success . toHtml $ mr MsgLanguageChanged - redirect route + app <- getYesod + let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang'' + | otherwise = renderMessage app [] + addMessage Success . toHtml $ mr MsgLanguageChanged - invalidArgs ["Language form required"] + redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 5e3489ac0..983ea7b3c 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -399,7 +399,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do Nothing -> do addMessageI Info MsgInvitationDeclined deleteBy . UniqueInvitation itEmail $ invRef @junction fid - return . Just $ SomeRoute HomeR + return . Just $ SomeRoute NewsR Just (jData, formCtx) -> do let junction = review _InvitableJunction (invitee, fid, jData) mResult <- invitationInsertHook itEmail fEnt iData junction formCtx $ insertUniqueEntity junction diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index b722fb338..c2f083f37 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -10,6 +10,7 @@ import Model.Submission as Import import Model.Tokens as Import import Utils.Tokens as Import import Utils.Frontend.Modal as Import +import Utils.Frontend.Notification as Import import Utils.Lens as Import import Settings as Import diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 78af6cfaf..3a3e2e8f6 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -46,6 +46,7 @@ import Data.Scientific import Data.Time.Clock (NominalDiffTime, nominalDay) import Utils +import Utils.Frontend.Notification -- import Utils.Message -- import Utils.PathPiece -- import Utils.Route @@ -869,26 +870,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) -formMessage Message{..} = do +formMessage msg = do return (FormSuccess (), FieldView { fvLabel = mempty , fvTooltip = Nothing , fvId = idFormMessageNoinput , fvErrors = Nothing , fvRequired = False - , fvInput = [whamlet| - $newline never -
-
- #{messageContent} - |] + , fvInput = notification NotificationNarrow msg }) - where - defaultIcon = case messageStatus of - Success -> "check-circle" - Info -> "info-circle" - Warning -> "exclamation-circle" - Error -> "exclamation-triangle" --------------------- -- Form evaluation -- diff --git a/src/Utils/Frontend/Notification.hs b/src/Utils/Frontend/Notification.hs new file mode 100644 index 000000000..d4ec0758a --- /dev/null +++ b/src/Utils/Frontend/Notification.hs @@ -0,0 +1,43 @@ +module Utils.Frontend.Notification + ( NotificationType(..) + , notification + , notificationWidget + ) where + +import ClassyPrelude.Yesod +import Settings + +import Utils.Message +import Utils.Icon + +import Control.Lens +import Control.Lens.Extras (is) + + +data NotificationType + = NotificationNarrow + | NotificationBroad + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +makePrisms ''NotificationType + + +notification :: NotificationType + -> Message + -> WidgetFor site () +notification nType Message{ messageIcon = messageIcon', .. } + = $(widgetFile "widgets/notification") + where + messageIcon = fromMaybe defaultIcon messageIcon' + defaultIcon = case messageStatus of + Success -> IconNotificationSuccess + Info -> IconNotificationInfo + Warning -> IconNotificationWarning + Error -> IconNotificationError + +notificationWidget :: Yesod site + => NotificationType + -> MessageStatus + -> WidgetFor site () + -> WidgetFor site () +notificationWidget nType ms = notification nType <=< messageWidget ms diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e9fdcce66..6bbaae5b2 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -63,44 +63,58 @@ data Icon | IconApplicationVeto | IconApplicationFiles | IconTooltipDefault - deriving (Eq, Ord, Enum, Bounded, Show, Read) + | IconNotificationSuccess + | IconNotificationInfo + | IconNotificationWarning + | IconNotificationError + | IconFavourite + | IconLanguage + | IconNavContainerClose + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text iconText = \case - IconNew -> "seedling" - IconOK -> "check" - IconNotOK -> "times" - IconWarning -> "exclamation" - IconProblem -> "bolt" - IconVisible -> "eye" - IconInvisible -> "eye-slash" - IconCourse -> "graduation-cap" - IconEnrolTrue -> "user-plus" - IconEnrolFalse -> "user-slash" - IconPlanned -> "cog" - IconAnnounce -> "bullhorn" - IconExam -> "poll-h" - IconExamRegisterTrue -> "calendar-check" - IconExamRegisterFalse -> "calendar-times" - IconCommentTrue -> "comment-alt" - IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free - IconLink -> "link" - IconFileDownload -> "file-download" - IconFileUpload -> "file-upload" - IconFileZip -> "file-archive" - IconFileCSV -> "file-csv" - IconSFTQuestion -> "question-circle" -- for SheetFileType only, should all be round (similar) - IconSFTHint -> "life-ring" -- for SheetFileType only - IconSFTSolution -> "exclamation-circle" -- for SheetFileType only - IconSFTMarking -> "check-circle" -- for SheetFileType only - IconEmail -> "envelope" - IconRegisterTemplate -> "file-alt" - IconApplyTrue -> "file-alt" - IconApplyFalse -> "trash" - IconNoCorrectors -> "user-slash" - IconApplicationVeto -> "times" - IconApplicationFiles -> "file-alt" - IconTooltipDefault -> "question-circle" + IconNew -> "seedling" + IconOK -> "check" + IconNotOK -> "times" + IconWarning -> "exclamation" + IconProblem -> "bolt" + IconVisible -> "eye" + IconInvisible -> "eye-slash" + IconCourse -> "graduation-cap" + IconEnrolTrue -> "user-plus" + IconEnrolFalse -> "user-slash" + IconPlanned -> "cog" + IconAnnounce -> "bullhorn" + IconExam -> "poll-h" + IconExamRegisterTrue -> "calendar-check" + IconExamRegisterFalse -> "calendar-times" + IconCommentTrue -> "comment-alt" + IconCommentFalse -> "comment-alt-slash" + IconLink -> "link" + IconFileDownload -> "file-download" + IconFileUpload -> "file-upload" + IconFileZip -> "file-archive" + IconFileCSV -> "file-csv" + IconSFTQuestion -> "question-circle" -- for SheetFileType only, should all be round (similar) + IconSFTHint -> "life-ring" -- for SheetFileType only + IconSFTSolution -> "exclamation-circle" -- for SheetFileType only + IconSFTMarking -> "check-circle" -- for SheetFileType only + IconEmail -> "envelope" + IconRegisterTemplate -> "file-alt" + IconApplyTrue -> "file-alt" + IconApplyFalse -> "trash" + IconNoCorrectors -> "user-slash" + IconApplicationVeto -> "times" + IconApplicationFiles -> "file-alt" + IconTooltipDefault -> "question-circle" + IconNotificationSuccess -> "check-circle" + IconNotificationInfo -> "info-circle" + IconNotificationWarning -> "exclamation-circle" + IconNotificationError -> "exclamation-triangle" + IconFavourite -> "star" + IconLanguage -> "flag-alt" + IconNavContainerClose -> "chevron-up" instance Universe Icon instance Finite Icon diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index c4a2f1a82..e52157a18 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -1,5 +1,6 @@ module Utils.Lens.TH - ( makeLenses_, makeClassyFor_ + ( lensRules_ + , makeLenses_, makeClassyFor_ , multifocusG, multifocusL ) where diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 59bfbb926..71b4d95a3 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -6,7 +6,7 @@ module Utils.Message , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) - , messageIconI + , messageIconI, messageIconIHamlet, messageIconWidget , messageI, messageIHamlet, messageFile, messageWidget, messageTooltip ) where @@ -163,6 +163,15 @@ messageIHamlet ms iHamlet = do let mi = Nothing Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi +messageIconIHamlet :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + , HandlerSite m ~ site + ) => MessageStatus -> Icon -> HtmlUrlI18n msg (Route site) -> m Message +messageIconIHamlet messageStatus (Just -> messageIcon) iHamlet = do + mr <- getMessageRender + messageContent <- withUrlRenderer (iHamlet $ toHtml . mr) + return Message{..} + addMessageFile :: MessageStatus -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] @@ -189,6 +198,15 @@ messageWidget mc wgt = do PageContent{pageBody} <- liftHandler $ widgetToPageContent wgt messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) +messageIconWidget :: forall m site. + ( MonadHandler m + , HandlerSite m ~ site + , Yesod site + ) => MessageStatus -> Icon -> WidgetFor site () -> m Message +messageIconWidget ms mi wgt = do + PageContent{pageBody} <- liftHandler $ widgetToPageContent wgt + messageIconIHamlet ms mi (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) + getMessages :: MonadHandler m => m [Message] getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index f78926740..cdc4a80c1 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -58,6 +58,7 @@ data GlobalPostParam = PostFormIdentifier | PostDBCsvImportAction | PostLoginDummy | PostExamAutoOccurrencePrevious + | PostLanguage deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 22fe5fa2d..b59084d7e 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -1,5 +1,11 @@ $newline never $if not isModal + $with containers <- filter isNavHeaderContainer nav + $if not (null containers) + + $forall (_, containerIdent, _, _) <- containers + + ^{asidenav} @@ -15,7 +21,7 @@ $if not isModal $if not isModal - $if not $ Just HomeR == mcurrentRoute + $if not $ Just NewsR == mcurrentRoute ^{breadcrumbsWgt}
diff --git a/templates/exam-office/exam-results.hamlet b/templates/exam-office/exam-results.hamlet index 29d1ad6c1..5b077e6d8 100644 --- a/templates/exam-office/exam-results.hamlet +++ b/templates/exam-office/exam-results.hamlet @@ -3,7 +3,5 @@ $newline never ^{closeWgt}
$if hasUsers -
-
- _{MsgExamGradesExplanation} + ^{examGradesExplanation} ^{examUsersTable} diff --git a/templates/exam-office/externalExamGrades.hamlet b/templates/exam-office/externalExamGrades.hamlet index 66541d890..8e8fbf212 100644 --- a/templates/exam-office/externalExamGrades.hamlet +++ b/templates/exam-office/externalExamGrades.hamlet @@ -1,6 +1,4 @@ $newline never $if hasUsers -
-
- _{MsgExamGradesExplanation} + ^{examGradesExplanation} ^{table} diff --git a/templates/i18n/exam-office/exam-grades-explanation/de-de-formal.hamlet b/templates/i18n/exam-office/exam-grades-explanation/de-de-formal.hamlet new file mode 100644 index 000000000..1ce6651a6 --- /dev/null +++ b/templates/i18n/exam-office/exam-grades-explanation/de-de-formal.hamlet @@ -0,0 +1,9 @@ +$newline never +

+ Diese Ansicht zeigt die selben Daten an, wie die Tabelle von Prüfungsteilnehmern.
+ Anpassen der Teilnehmerdaten und Ergebnisse ist nur dort möglich. + +

+ Hier können Sie vor Allem einsehen und markieren, welche # + Prüfungsleistungen von den zuständigen Prüfungsbeauftragten bereits # + vollständig bearbeitet wurden. diff --git a/templates/i18n/exam-office/exam-grades-explanation/en-eu.hamlet b/templates/i18n/exam-office/exam-grades-explanation/en-eu.hamlet new file mode 100644 index 000000000..1e72c4004 --- /dev/null +++ b/templates/i18n/exam-office/exam-grades-explanation/en-eu.hamlet @@ -0,0 +1,9 @@ +$newline never +

+ This view shows the same data as the table of exam participants.
+ Changing participant's data and achievements is only possible via # + the table of exam participants. + +

+ Primarily, this view allows you to check and adjust which exam # + achievements were properly handled by the relevant exam offices. diff --git a/templates/i18n/exam-users/computed-values-tip/de-de-formal.hamlet b/templates/i18n/exam-users/computed-values-tip/de-de-formal.hamlet index 22f185706..22cf3ac4e 100644 --- a/templates/i18n/exam-users/computed-values-tip/de-de-formal.hamlet +++ b/templates/i18n/exam-users/computed-values-tip/de-de-formal.hamlet @@ -1,24 +1,22 @@ $newline never -

-
-

- Die Tabelle enthält Werte, die automatisch berechnet wurden. -

- Automatisch berechnete Werte (Bonus und Prüfungsergebnis) werden weder dem # - entsprechenden Teilnehmer angezeigt, noch an das Prüfungsamt gemeldet # - bevor sie manuell übernommen wurden.
- Hierzu können Sie die Aktion „Berechnetes Prüfungsergebnis übernehmen“ # - verwenden. -

- Sie können die automatisch berechneten Werte auch manuell (via CSV-Import) # - überschreiben.
- Wenn die so gesetzten Werte nicht den automatisch Berechneten entsprechen # - sind sie inkonsistent. -

- Automatisch berechnete Werte sind gekennzeichnet wie folgt: +

+ Die Tabelle enthält Werte, die automatisch berechnet wurden. +

+ Automatisch berechnete Werte (Bonus und Prüfungsergebnis) werden weder dem # + entsprechenden Teilnehmer angezeigt, noch an das Prüfungsamt gemeldet # + bevor sie manuell übernommen wurden.
+ Hierzu können Sie die Aktion „Berechnetes Prüfungsergebnis übernehmen“ # + verwenden. +

+ Sie können die automatisch berechneten Werte auch manuell (via CSV-Import) # + überschreiben.
+ Wenn die so gesetzten Werte nicht den automatisch Berechneten entsprechen # + sind sie inkonsistent. +

+ Automatisch berechnete Werte sind gekennzeichnet wie folgt: - - -
Automatisch berechnet - Normaler Wert - Inkonsistent + + +
Automatisch berechnet + Normaler Wert + Inkonsistent diff --git a/templates/i18n/exam-users/computed-values-tip/en-eu.hamlet b/templates/i18n/exam-users/computed-values-tip/en-eu.hamlet index 4d3f28283..438c706d0 100644 --- a/templates/i18n/exam-users/computed-values-tip/en-eu.hamlet +++ b/templates/i18n/exam-users/computed-values-tip/en-eu.hamlet @@ -1,23 +1,21 @@ $newline never -
-
-

- This table contains values that were computed automatically. -

- Values computed automatically (bonus and result) are shown to neither the # - participant nor relevant exam offices until they are manually accepted.
- To do this you may use the action “Accept computed result”. -

- You are also able to override the automatically computed values manually # - (via CSV import).
+

+ This table contains values that were computed automatically. +

+ Values computed automatically (bonus and result) are shown to neither the # + participant nor relevant exam offices until they are manually accepted.
+ To do this you may use the action “Accept computed result”. +

+ You are also able to override the automatically computed values manually # + (via CSV import).
- If values thus overriden do not match the automatically computed values # - they are considered inconsistent. -

- Automatically computed values are marked as follows: + If values thus overriden do not match the automatically computed values # + they are considered inconsistent. +

+ Automatically computed values are marked as follows: - - -
Automatically computed - Normal value - Inconsistent + + +
Automatically computed + Normal value + Inconsistent diff --git a/templates/i18n/pitch/de-de-formal.hamlet b/templates/i18n/pitch/de-de-formal.hamlet new file mode 100644 index 000000000..779f13e3a --- /dev/null +++ b/templates/i18n/pitch/de-de-formal.hamlet @@ -0,0 +1,11 @@ +$newline never +

+ Uni2work ist ein Lehrverwaltungssystem, welches an der # + Ludwig-Maximilians-Universität München entwickelt und eingesetzt # + wird. +

+ Insbesondere unterstützt Uni2work teilnehmende Institute bei # + Übungsbetrieb, Prüfungs- und Notenverwaltung und bietet vollständige # + Kurshomepages inkl. Vorlesungsmaterial und Terminen. + + diff --git a/templates/i18n/pitch/en-eu.hamlet b/templates/i18n/pitch/en-eu.hamlet new file mode 100644 index 000000000..fce1db863 --- /dev/null +++ b/templates/i18n/pitch/en-eu.hamlet @@ -0,0 +1,8 @@ +$newline never +

+ Uni2work is a teaching management system, developed and deployed at # + Ludwig-Maximilians-Universität München. +

+ Uni2work supports participating departments in managing their course # + exercises, exams and exam achievements, and provides complete course # + homepages including course material and dates. diff --git a/templates/i18n/unauth-home/de-de-formal.hamlet b/templates/i18n/unauth-news/de-de-formal.hamlet similarity index 100% rename from templates/i18n/unauth-home/de-de-formal.hamlet rename to templates/i18n/unauth-news/de-de-formal.hamlet diff --git a/templates/i18n/unauth-home/en-eu.hamlet b/templates/i18n/unauth-news/en-eu.hamlet similarity index 100% rename from templates/i18n/unauth-home/en-eu.hamlet rename to templates/i18n/unauth-news/en-eu.hamlet diff --git a/templates/home/openAllocations.hamlet b/templates/news/openAllocations.hamlet similarity index 100% rename from templates/home/openAllocations.hamlet rename to templates/news/openAllocations.hamlet diff --git a/templates/home/upcomingExams.hamlet b/templates/news/upcomingExams.hamlet similarity index 80% rename from templates/home/upcomingExams.hamlet rename to templates/news/upcomingExams.hamlet index 29ee05df4..e87d99dbf 100644 --- a/templates/home/upcomingExams.hamlet +++ b/templates/news/upcomingExams.hamlet @@ -1,6 +1,6 @@ $newline never

-

_{MsgHomeUpcomingExams} +

_{MsgNewsUpcomingExams} $if hasExams ^{examTable} $else diff --git a/templates/home/upcomingSheets.hamlet b/templates/news/upcomingSheets.hamlet similarity index 56% rename from templates/home/upcomingSheets.hamlet rename to templates/news/upcomingSheets.hamlet index f82dcf616..ed8fea2ab 100644 --- a/templates/home/upcomingSheets.hamlet +++ b/templates/news/upcomingSheets.hamlet @@ -1,4 +1,4 @@ $newline never
-

_{MsgHomeUpcomingSheets} +

_{MsgNewsUpcomingSheets} ^{sheetTable} diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index 9d483b90b..d40a61264 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -28,12 +28,9 @@ $newline never
#{courseName}