fradrive/src/Handler/Info.hs

-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.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 ($(orGitRevisionEnv 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  = $(orGitRevisionEnv gitDescribeDate)
    $(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 _ FAQLoginExpired = return True
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 _ _ = return False

prioFAQ :: Monad m
        => Route UniWorX -> FAQItem -> m Rational
prioFAQ _ FAQLoginExpired = return 2
prioFAQ _ FAQNoCampusAccount = return 1
prioFAQ _ FAQCampusCantLogin = return 1
prioFAQ _ FAQForgottenPassword = return 1
prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1


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} |]