207 lines
9.7 KiB
Haskell
207 lines
9.7 KiB
Haskell
-- 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
|