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 as E
import qualified Database.Esqueleto.Utils as E

import Development.GitRev

import Auth.LDAP (ADError(..), ADInvalidCredentials(..))

-- | 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
  changelogEntries' <- runDB $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] []
  let changelogEntries = Map.fromListWith Set.union
        [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)
        | Entity _ ChangelogItemFirstSeen{..} <- changelogEntries'
        ]
  
  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")

  where
    changelogItems = $(i18nWidgetFiles "changelog")


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

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 :: ( MonadHandler m, HandlerSite m ~ UniWorX
              , MonadThrow m
              , MonadUnliftIO 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
           , MonadUnliftIO 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 _ FAQAllocationNoPlaces = maybeT (return False) $ do
  uid <- MaybeT maybeAuthId
  now <- liftIO getCurrentTime
  liftHandler . runDB . E.selectExists . E.from $ \allocation -> do
    let doneSince = E.subSelectMaybe . E.from $ \participant -> do
          E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (allocation E.^. AllocationId)
          return . E.max_ $ participant E.^. CourseParticipantRegistration
        isAllocationUser = E.exists . E.from $ \allocationUser ->
          E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. allocation E.^. AllocationId
               E.&&. allocationUser E.^. AllocationUserUser E.==. E.val uid
        isApplicant = E.exists . E.from $ \courseApplication ->
          E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
               E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
    E.where_ $ isAllocationUser E.||. isApplicant
    E.where_ $ E.maybe E.false (\done -> done E.>=. E.val (addUTCTime (-7 * nominalDay) now)) doneSince
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 _ FAQAllocationNoPlaces = return 2
prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3