245 lines
9.0 KiB
Haskell
245 lines
9.0 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Info where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Info.TH
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!))
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Development.GitRev
|
|
|
|
import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
|
|
|
|
import Yesod.Auth.Message(AuthMessage(..))
|
|
|
|
|
|
pickLegalExternalLang :: Handler LegalExternal
|
|
pickLegalExternalLang = do
|
|
langMap <- $cachedHereBinary ("legal_external"::Text) makeMapLegalExternal
|
|
availLangs <- case nonEmpty' (Map.keys langMap) of
|
|
Just ls -> pure ls
|
|
Nothing -> $logErrorS "Legal" "Configuration of external legal links is missing." >> notFound
|
|
lang <- selectLanguage availLangs
|
|
return $ langMap ! lang
|
|
where
|
|
makeMapLegalExternal :: Handler (Map Lang LegalExternal)
|
|
makeMapLegalExternal = do
|
|
legExs <- getsYesod $ view _appLegalExternal
|
|
return $ Set.foldl' (\acc le -> Map.singleton (externalLanguage le) le <> acc) mempty legExs
|
|
-- return $ Map.fromAscList [(externalLanguage le,le) | le <- Set.toAscList legExs]
|
|
|
|
|
|
-- | Versionsgeschichte
|
|
getVersionR :: Handler TypedContent
|
|
getVersionR = selectRep $ do
|
|
provideRep $
|
|
return ($gitDescribe :: Text)
|
|
provideRep getInfoR
|
|
|
|
|
|
getImprintR :: Handler Html
|
|
getImprintR = do
|
|
le <- pickLegalExternalLang
|
|
redirect $ externalImprint le
|
|
|
|
getDataProtectionR :: Handler Html
|
|
getDataProtectionR = do
|
|
le <- pickLegalExternalLang
|
|
redirect $ externalDataProtection le
|
|
|
|
getPaymentsR :: Handler Html
|
|
getPaymentsR = do
|
|
le <- pickLegalExternalLang
|
|
redirect $ externalPayments le
|
|
|
|
getTermsOfUseR :: Handler Html
|
|
getTermsOfUseR = do
|
|
le <- pickLegalExternalLang
|
|
redirect $ externalTermsOfUse le
|
|
|
|
getInfoSupervisorR :: Handler Html
|
|
getInfoSupervisorR = error "TODO"
|
|
|
|
-- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
|
|
getLegalR :: Handler Html
|
|
getLegalR = do
|
|
siteLayoutMsg MsgHeadingLegal $ do
|
|
setTitleI MsgLegalHeading
|
|
let dataProtection = $(i18nWidgetFile "data-protection")
|
|
termsUse = $(i18nWidgetFile "terms-of-use")
|
|
copyright = $(i18nWidgetFile "copyright")
|
|
imprint = $(i18nWidgetFile "imprint")
|
|
$(widgetFile "legal")
|
|
|
|
|
|
-- | Allgemeine Informationen
|
|
getInfoR :: Handler Html
|
|
getInfoR = do
|
|
changelogEntries' <- runDB $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] []
|
|
let changelogEntries = Map.fromListWith Set.union
|
|
[ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)
|
|
| Entity _ ChangelogItemFirstSeen{..} <- changelogEntries'
|
|
]
|
|
changelogItems = $(i18nWidgetFiles "changelog")
|
|
|
|
siteLayoutMsg MsgInfoHeading $ do
|
|
setTitleI MsgInfoHeading
|
|
let features = $(i18nWidgetFile "featureList")
|
|
changeLog = $(widgetFile "changelog")
|
|
knownBugs = $(i18nWidgetFile "knownBugs")
|
|
implementation = $(i18nWidgetFile "implementation")
|
|
gitInfo :: Text
|
|
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
|
|
$(widgetFile "versionHistory")
|
|
|
|
|
|
getGlossaryR :: Handler Html
|
|
getGlossaryR =
|
|
siteLayoutMsg MsgGlossaryTitle $ do
|
|
setTitleI MsgGlossaryTitle
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let
|
|
entries' = sortOn (CI.mk . view _2) $ do
|
|
(k, v) <- Map.toList entries
|
|
msg <- maybeToList $ Map.lookup k msgMap
|
|
return (k, mr msg, v)
|
|
$(widgetFile "glossary")
|
|
where
|
|
entries = $(i18nWidgetFiles "glossary")
|
|
msgMap = $(glossaryTerms "glossary")
|
|
|
|
|
|
mkI18nWidgetEnum "FAQ" "faq"
|
|
mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal"
|
|
|
|
faqsWidget :: ( MonadAP m
|
|
, MonadThrow m
|
|
)
|
|
=> Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool)
|
|
faqsWidget mLimit route = do
|
|
faqs <- for route $ \route' -> filterM (showFAQ route') universeF
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let
|
|
rItems' = sortOn (CI.mk . views _1 mr) $ do
|
|
(k, wgt) <- Map.toList items
|
|
msg <- maybeToList $ Map.lookup k faqItemMap
|
|
whenIsJust faqs $ \faqs' ->
|
|
guard $ msg `elem` faqs'
|
|
return (msg, wgt)
|
|
|
|
rItems <- case (,) <$> route <*> mLimit of
|
|
Nothing -> return rItems'
|
|
Just (route', limit) -> do
|
|
let wIndices = zip [0..] rItems'
|
|
wPrios <- forM wIndices $ \x@(_, (msg, _)) -> (, x) . Just <$> prioFAQ route' msg
|
|
let prioLimited = go Nothing [] $ sortOn (views _1 Down) wPrios
|
|
where
|
|
go _ acc [] = acc
|
|
go maxP acc ((p, x) : xs)
|
|
| maxP == Just p || length acc < fromIntegral limit
|
|
= go (Just p) (x : acc) xs
|
|
| otherwise
|
|
= acc
|
|
return . map (view _2) $ sortOn (view _1) prioLimited
|
|
|
|
let truncated = length rItems < length rItems'
|
|
|
|
return ( guardOn (not $ null rItems') $(widgetFile "faq")
|
|
, truncated
|
|
)
|
|
where
|
|
items = $(i18nWidgetFiles "faq")
|
|
|
|
faqLink :: FAQItem -> Widget
|
|
faqLink = toWidget <=< toTextUrl . (FaqR :#:)
|
|
|
|
|
|
getFaqR :: Handler Html
|
|
getFaqR =
|
|
siteLayoutMsg MsgFaqTitle $ do
|
|
setTitleI MsgFaqTitle
|
|
|
|
fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
|
|
|
|
showFAQ :: ( MonadAP m
|
|
, MonadThrow m
|
|
)
|
|
=> Route UniWorX -> FAQItem -> m Bool
|
|
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
|
|
showFAQ (AuthR _) FAQCampusCantLogin = return True
|
|
showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId
|
|
showFAQ (AuthR _) FAQForgottenPassword = return True
|
|
showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId
|
|
showFAQ _ FAQNotLecturerHowToCreateCourses
|
|
= and2M (is _Just <$> maybeAuthId)
|
|
(not <$> hasWriteAccessTo CourseNewR)
|
|
showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
|
|
= and2M (is _Just <$> maybeAuthId)
|
|
(or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
|
|
(hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
|
|
)
|
|
showFAQ (CExamR tid ssh csh examn _) FAQExamPoints
|
|
= and2M (hasWriteAccessTo $ CExamR tid ssh csh examn EEditR)
|
|
noExamParts
|
|
where
|
|
noExamParts = liftHandler . runDB . E.selectNotExists . E.from $ \(examPart `E.InnerJoin` exam `E.InnerJoin` course) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
|
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.&&. exam E.^. ExamName E.==. E.val examn
|
|
showFAQ _ FAQInvalidCredentialsAdAccountDisabled = maybeT (return False) $ do
|
|
guardM $ is _Nothing <$> maybeAuthId
|
|
sessionError <- MaybeT $ lookupSessionJson SessionError
|
|
guard $ sessionError == PermissionDenied (toPathPiece $ ADInvalidCredentials ADAccountDisabled)
|
|
return True
|
|
showFAQ _ _ = return False
|
|
|
|
prioFAQ :: Monad m
|
|
=> Route UniWorX -> FAQItem -> m Rational
|
|
prioFAQ _ FAQNoCampusAccount = return 1
|
|
prioFAQ _ FAQCampusCantLogin = return 1
|
|
prioFAQ _ FAQForgottenPassword = return 1
|
|
prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1
|
|
prioFAQ _ FAQCourseCorrectorsTutors = return 1
|
|
prioFAQ _ FAQExamPoints = return 2
|
|
prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3
|
|
|
|
|
|
getInfoLecturerR :: Handler Html
|
|
getInfoLecturerR =
|
|
siteLayoutMsg MsgInfoLecturerTitle $ do
|
|
setTitleI MsgInfoLecturerTitle
|
|
$(i18nWidgetFile "info-lecturer")
|
|
where
|
|
tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX ()
|
|
tooltipNew = [whamlet| _{MsgLecturerInfoTooltipNew} |]
|
|
tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |]
|
|
tooltipPlanned = [whamlet| _{MsgLecturerInfoTooltipPlanned} |]
|
|
tooltipNewU2W = [whamlet| _{MsgLecturerInfoTooltipNewU2W} |]
|
|
newU2WFeat, probFeatInline, plannedFeat, plannedFeatInline :: WidgetFor UniWorX ()
|
|
newU2WFeat = [whamlet| ^{iconTooltip tooltipNewU2W (Just IconAnnounce) True} |] -- to be used inside text blocks
|
|
probFeatInline = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |] -- to be used inside text blocks
|
|
plannedFeat = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |]
|
|
plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |] -- to be used inside text blocks
|
|
|
|
-- new feature with given introduction date
|
|
newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
|
|
newFeat y m d = do
|
|
currentTime <- liftIO getCurrentTime
|
|
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0
|
|
if currentTime > expiryTime
|
|
then mempty
|
|
else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]
|