157 lines
6.5 KiB
Haskell
157 lines
6.5 KiB
Haskell
module Handler.Utils
|
|
( module Handler.Utils
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import qualified Data.Text.Encoding as T
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Conduit.List as Conduit
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
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
|
|
import Handler.Utils.Files as Handler.Utils
|
|
|
|
import Handler.Utils.Term as Handler.Utils
|
|
|
|
import Control.Monad.Logger
|
|
|
|
|
|
-- | Simply send a `File`-Value
|
|
sendThisFile :: File -> Handler TypedContent
|
|
sendThisFile File{..}
|
|
| Just fileContent' <- fileContent = do
|
|
setContentDisposition' . Just $ takeFileName fileTitle
|
|
return $ TypedContent (simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
|
| otherwise = sendResponseStatus noContent204 ()
|
|
|
|
-- | Serve a single file, identified through a given DB query
|
|
serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
|
serveOneFile source = do
|
|
results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
|
|
case results of
|
|
[file] -> sendThisFile =<< runDB (sourceFile' file)
|
|
[] -> notFound
|
|
_other -> do
|
|
$logErrorS "SFileR" "Multiple matching files found."
|
|
error "Multiple matching files found."
|
|
|
|
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
|
--
|
|
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
|
serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
|
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
|
|
|
|
serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent
|
|
serveSomeFiles' archiveName source = do
|
|
results <- runDB . runConduit $ source .| peekN 2
|
|
|
|
$logDebugS "serveSomeFiles" . tshow $ length results
|
|
|
|
case results of
|
|
[] -> notFound
|
|
[file] -> sendThisFile =<< either (runDB . sourceFile') return file
|
|
_moreFiles -> do
|
|
setContentDisposition' $ Just archiveName
|
|
respondSourceDB typeZip $ do
|
|
let zipComment = T.encodeUtf8 $ pack archiveName
|
|
source .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
|
|
|
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
|
--
|
|
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
|
serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
|
serveZipArchive archiveName source = do
|
|
results <- runDB . runConduit $ source .| peekN 1
|
|
|
|
$logDebugS "serveZipArchive" . tshow $ length results
|
|
|
|
case results of
|
|
[] -> notFound
|
|
_moreFiles -> do
|
|
setContentDisposition' $ Just archiveName
|
|
respondSourceDB typeZip $ do
|
|
let zipComment = T.encodeUtf8 $ pack archiveName
|
|
source .| sourceFiles' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
|
|
|
|
|
-- | 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 :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h
|
|
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
|
|
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
|
|
guardAuthorizedFor link val =
|
|
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
|
|
|
|
|
|
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}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
|
|]
|
|
|
|
|
|
getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
|
getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
|