fradrive/src/Handler/Info.hs

module Handler.Info where

import Import
import Handler.Utils
import Handler.Info.TH

import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import Development.GitRev

-- | Versionsgeschichte
getVersionR :: Handler TypedContent
getVersionR = selectRep $ do
  provideRep $
    return ($gitDescribe :: Text)
  provideRep getInfoR


-- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
getLegalR :: Handler Html
getLegalR =
  siteLayoutMsg' MsgMenuLegal $ 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
  siteLayoutMsg MsgInfoHeading $ do
    setTitleI MsgInfoHeading
    let features       = $(i18nWidgetFile "featureList")
        changeLog      = $(i18nWidgetFile "changelog")
        knownBugs      = $(i18nWidgetFile "knownBugs")
        implementation = $(i18nWidgetFile "implementation")
        gitInfo :: Text
        gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"
    $(widgetFile "versionHistory")


getInfoLecturerR :: Handler Html
getInfoLecturerR =
  siteLayoutMsg' MsgInfoLecturerTitle $ do
    setTitleI MsgInfoLecturerTitle
    $(i18nWidgetFile "info-lecturer")
  where
    allocationInfo = $(i18nWidgetFile "allocation-info")
    
    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 year month day = do
      currentTime <- liftIO getCurrentTime
      let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
      if currentTime > expiryTime
        then mempty
        else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]

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")


mkFaqItems "faq"
mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"

faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
              , 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 :: ( MonadHandler m, HandlerSite m ~ UniWorX
           , 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 _ _ = 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