-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.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.Utils
  ( module Handler.Utils
  ) where

import Import hiding (link)

import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set

import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils

import Handler.Utils.Zip        as Handler.Utils
import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
-- import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet      as Handler.Utils
import Handler.Utils.Mail       as Handler.Utils
import Handler.Utils.ContentDisposition as Handler.Utils
import Handler.Utils.I18n       as Handler.Utils
import Handler.Utils.Widgets    as Handler.Utils
import Handler.Utils.Database   as Handler.Utils
import Handler.Utils.Occurrences as Handler.Utils
import Handler.Utils.Memcached  as Handler.Utils hiding (manageMemcachedLocalInvalidations)
import Handler.Utils.Files      as Handler.Utils
import Handler.Utils.Download   as Handler.Utils
import Handler.Utils.AuthorshipStatement as Handler.Utils
--import Handler.Utils.Company    as Handler.Utils
import Handler.Utils.Qualification as Handler.Utils

import Handler.Utils.Term as Handler.Utils

-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed

import Control.Monad.Logger


-- | default check if the user an active admin
checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool
checkAdmin = liftHandler $ hasReadAccessTo AdminR


-- | Prefix a message with a short course id,
--   eg. for window title bars, etc.
--   This function should help to make this consistent everywhere
prependCourseTitle :: (RenderMessage UniWorX msg) =>
  TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
prependCourseTitle tid ssh csh msg = UniWorXMessages
  [ SomeMessage $ toPathPiece tid
  , SomeMessage dashText
  , SomeMessage $ toPathPiece ssh
  , SomeMessage dashText
  , SomeMessage csh
  , SomeMessage colonText
  , SomeMessage msg
  ]
 where
    dashText :: Text
    dashText = "-"

    colonText :: Text
    colonText = ":"

warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
warnTermDays tid timeNames = do
  Term{..} <- get404 tid
  MsgRenderer mr <- getMsgRenderer
  let alldays       = Map.keysSet timeNames
      warnholidays  = let hdays = Set.fromList termHolidays in
                      Set.filter (\(utctDay -> d) -> Set.member d hdays)                         alldays
      outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart        || d > termEnd       ) alldays
      outoflecture  = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
      warnI msg d   = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
  forM_ warnholidays  $ warnI MsgDayIsAHoliday
  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm


-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( MonadThrow m
                      , MonadTrans t, MonadPlus (t (ReaderT SqlBackend m))
                      , MonadAP (ReaderT SqlBackend m)
                      )
                   => Route UniWorX -> a -> t (ReaderT SqlBackend m) a
guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link


runAppLoggingT :: UniWorX -> LoggingT m a -> m a
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
  where
    logFunc loc src lvl str = do
      f <- messageLoggerSource app <$> readTVarIO loggerTVar
      f loc src lvl str

studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
  [whamlet|
    $newline never
    _{StudyDegreeTerm degree terms}, _{MsgTableStudyFeatureAge} #{studyFeaturesSemester}
  |]


getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth


-- | Conditional redirect that hides the URL if the user is not authorized for the route
redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectAccess url = liftHandler $ do
  -- must hide URL if not authorized
  access <- isAuthorized url False
  case access of
    Authorized -> redirect url
    _          -> permissionDeniedI MsgUnauthorizedRedirect

redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
redirectAccessWith status url = liftHandler $ do
  -- must hide URL if not authorized
  access <- isAuthorized url False
  case access of
    Authorized -> redirectWith status url
    _          -> permissionDeniedI MsgUnauthorizedRedirect

redirectAlternatives :: (MonadHandler m, HandlerSite m ~ UniWorX) => NonEmpty (Route (HandlerSite m)) -> m a
redirectAlternatives = go
  where
    go (nunsnoc -> ([], r)) = redirectAccess r
    go (nunsnoc -> (r' : rs, r)) = liftHandler $ do
      access <- isAuthorized r' False
      case access of
        Authorized -> redirect r'
        _          -> redirectAlternatives (nsnoc rs r)

    nunsnoc (x :| xs) = case nonEmpty xs of
      Nothing  -> ([], x)
      Just xs' -> over _1 (x :) $ nunsnoc xs'
    nsnoc [] x = x :| []
    nsnoc (x' : xs) x = x' :| (xs ++ [x])

-- | redirect to currentRoute, if Just otherwise to given default
reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reload r = getCurrentRoute >>= redirect . fromMaybe r

-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reloadKeepGetParams r = liftHandler $ do
  getps <- reqGetParams <$> getRequest
  route <- fromMaybe r  <$> getCurrentRoute
  -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
  -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
  redirect (route, getps)

-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do
  getps <- reqGetParams <$> getRequest
  redirect (route, getps)


adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
adminProblemCell AdminProblemNewCompany{}
  = i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
  = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
  = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
  = i18nCell MsgAdminProblemCompanySuperiorChange
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
  = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
  = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemUnknown{adminProblemText}
  = textCell $ "Problem: " <> adminProblemText

company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey

msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
  SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
  SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
  SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
  SomeMessages [SomeMessage   MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
  SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
  someMessages ["Problem: ", err]

updateAutomatic :: Bool -> Widget
-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
updateAutomatic True  = mempty
updateAutomatic False = do
  msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
  messageTooltip msg