267 lines
11 KiB
Haskell
267 lines
11 KiB
Haskell
module Handler.Utils
|
||
( module Handler.Utils
|
||
) where
|
||
|
||
import Import
|
||
|
||
import Utils.Lens
|
||
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.Encoding as T
|
||
import Data.Map ((!))
|
||
import qualified Data.Map as Map
|
||
import qualified Data.Set as Set
|
||
import Data.CaseInsensitive (original)
|
||
-- import qualified Data.CaseInsensitive as CI
|
||
import qualified Data.Conduit.List as Conduit
|
||
|
||
import Language.Haskell.TH
|
||
import Language.Haskell.TH.Syntax (qRunIO)
|
||
-- import Language.Haskell.TH.Datatype
|
||
|
||
import Text.Hamlet (shamletFile)
|
||
|
||
import Handler.Utils.DateTime as Handler.Utils
|
||
import Handler.Utils.Form as Handler.Utils
|
||
import Handler.Utils.Table as Handler.Utils
|
||
import Handler.Utils.Table.Pagination 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 System.Directory (listDirectory)
|
||
import System.FilePath.Posix (takeBaseName, takeFileName)
|
||
|
||
import qualified Data.List as List
|
||
import qualified Data.List.NonEmpty as NonEmpty
|
||
|
||
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 (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||
| otherwise = sendResponseStatus noContent204 ()
|
||
|
||
-- | Serve a single file, identified through a given DB query
|
||
serveOneFile :: Source (YesodDB UniWorX) File -> 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 file
|
||
[] -> notFound
|
||
other -> do
|
||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||
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 :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
|
||
serveSomeFiles archiveName source = do
|
||
results <- runDB . runConduit $ source .| peekN 2
|
||
|
||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||
|
||
case results of
|
||
[] -> notFound
|
||
[file] -> sendThisFile file
|
||
_moreFiles -> do
|
||
setContentDisposition' $ Just archiveName
|
||
respondSourceDB typeZip $ do
|
||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||
source .| 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 :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
|
||
serveZipArchive archiveName source = do
|
||
results <- runDB . runConduit $ source .| peekN 2
|
||
|
||
$logDebugS "serveZipArchive" . tshow $ length results
|
||
|
||
case results of
|
||
[] -> notFound
|
||
_moreFiles -> do
|
||
setContentDisposition' $ Just archiveName
|
||
respondSourceDB typeZip $ do
|
||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||
|
||
|
||
|
||
---------
|
||
-- Simple utilities for consistent display
|
||
-- Please use these throughout, to ensure that users have a consistent experience
|
||
|
||
tidFromText :: Text -> Maybe TermId
|
||
tidFromText = fmap TermKey . maybeRight . termFromText
|
||
|
||
-- | Display given UTCTime and maybe an invisible icon if it is in the future
|
||
--
|
||
-- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring)
|
||
visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget
|
||
visibleUTCTime dtf t = do
|
||
let timeStampWgt = formatTimeW dtf t
|
||
now <- liftIO getCurrentTime
|
||
if now >= t
|
||
then timeStampWgt
|
||
else $(widgetFile "widgets/date-time/yet-invisible")
|
||
|
||
|
||
-- | Simple link to a known route
|
||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||
|
||
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
||
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|]
|
||
|
||
-- | toWidget-Version of @nameHtml@, for convenience
|
||
nameWidget :: Text -- ^ userDisplayName
|
||
-> Text -- ^ userSurname
|
||
-> Widget
|
||
nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
||
|
||
-- | toWidget-Version of @nameEmailHtml@, for convenience
|
||
nameEmailWidget :: UserEmail -- ^ userEmail
|
||
-> Text -- ^ userDisplayName
|
||
-> Text -- ^ userSurname
|
||
-> Widget
|
||
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
|
||
|
||
-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
|
||
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
|
||
nameEmailWidget' = $(uncurryN 3) nameEmailWidget
|
||
|
||
-- | Show user's displayName, highlighting the surname if possible.
|
||
-- Otherwise appends the surname in parenthesis
|
||
nameHtml :: Text -> Text -> Html
|
||
nameHtml displayName surname
|
||
| null surname = toHtml displayName
|
||
| otherwise = case reverse $ T.splitOn surname displayName of
|
||
[_notContained] -> [shamlet|$newline never
|
||
#{displayName} (
|
||
<b .surname>#{surname}
|
||
)|]
|
||
(suffix:prefixes) ->
|
||
let prefix = T.intercalate surname $ reverse prefixes
|
||
in [shamlet|$newline never
|
||
#{prefix}
|
||
<b .surname>#{surname}
|
||
#{suffix}
|
||
|]
|
||
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
||
|
||
-- | Like nameHtml just show a users displayname with hightlighted surname,
|
||
-- but also wrap the name with a mailto-link
|
||
nameEmailHtml :: UserEmail -> Text -> Text -> Html
|
||
nameEmailHtml email displayName surname =
|
||
wrapMailto email $ nameHtml displayName surname
|
||
|
||
-- | Wrap mailto around given Html using single hamlet-file for consistency
|
||
wrapMailto :: UserEmail -> Html -> Html
|
||
wrapMailto (original -> email) linkText
|
||
| null email = linkText
|
||
| otherwise = $(shamletFile "templates/widgets/link-email.hamlet")
|
||
|
||
-- | Just show an email address in a standard way, for convenience inside hamlet files.
|
||
mailtoHtml :: UserEmail -> Html
|
||
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
|
||
|
||
-- | Generic i18n text for "edited at sometime by someone"
|
||
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
|
||
editedByW fmt tm usr = do
|
||
ft <- handlerToWidget $ formatTime fmt tm
|
||
[whamlet|_{MsgEditedBy usr ft}|]
|
||
|
||
-- | 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
|
||
|
||
-- | Add language dependent template files
|
||
--
|
||
-- For large files which are translated as a whole.
|
||
--
|
||
-- Argument musst be a directory under @/templates@,
|
||
-- which contains a file for each language,
|
||
-- eg. @imprint@ for choosing between
|
||
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
|
||
-- and @/templates/imprint/en.hamlet@
|
||
--
|
||
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
|
||
-- for directories)
|
||
-- @$ stack clean@ is required so new translations show up
|
||
i18nWidgetFile :: FilePath -> Q Exp
|
||
i18nWidgetFile basename = do
|
||
-- Construct list of available translations (@de@, @en@, ...) at compile time
|
||
let i18nDirectory = "templates" </> "i18n" </> basename
|
||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
|
||
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
|
||
|
||
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
||
ws <- newName "ws" -- Name for dispatch function
|
||
letE
|
||
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
|
||
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
|
||
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
||
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
|
||
|
||
|
||
|
||
-- | return a value only if the current user ist authorized for a given route
|
||
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger 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
|
||
|