134 lines
5.1 KiB
Haskell
134 lines
5.1 KiB
Haskell
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.Term as Handler.Utils
|
|
|
|
import Control.Monad.Logger
|
|
|
|
|
|
|
|
-- | 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])
|