110 lines
4.3 KiB
Haskell
110 lines
4.3 KiB
Haskell
module Handler.Utils
|
|
( module Handler.Utils
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Text as T
|
|
-- import qualified Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.CaseInsensitive (CI, original)
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
|
|
import Language.Haskell.TH (Q, Exp)
|
|
-- 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.Templates as Handler.Utils
|
|
import Handler.Utils.Mail as Handler.Utils
|
|
|
|
|
|
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
|
downloadFiles = do
|
|
mauth <- liftHandlerT maybeAuth
|
|
case mauth of
|
|
Just (Entity _ User{..}) -> return userDownloadFiles
|
|
Nothing -> do
|
|
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
|
|
return userDefaultDownloadFiles
|
|
|
|
tidFromText :: Text -> Maybe TermId
|
|
tidFromText = fmap TermKey . maybeRight . termFromText
|
|
|
|
simpleLink :: Widget -> Route UniWorX -> Widget
|
|
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
|
|
|
-- | toWidget-Version of @nameHtml@, for convenience
|
|
nameWidget :: Text -> Text -> Widget
|
|
nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
|
|
|
-- | toWidget-Version of @nameEmailHtml@, for convenience
|
|
nameEmailWidget :: CI Text -> Text -> Text -> Widget
|
|
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
|
|
|
|
-- | 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 :: CI Text -> Text -> Text -> Html
|
|
nameEmailHtml email displayName surname =
|
|
wrapMailto email $ nameHtml displayName surname
|
|
|
|
-- | Wrap mailto around given Html using single hamlet-file for consistency
|
|
wrapMailto :: CI Text -> 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 :: CI Text -> Html
|
|
mailtoHtml email = wrapMailto email $ toHtml email
|
|
|
|
warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
|
|
warnTermDays tid times = do
|
|
Term{..} <- get404 tid
|
|
let alldays = Set.map utctDay $ Set.fromList $ catMaybes times
|
|
warnholidays = Set.intersection alldays $ Set.fromList termHolidays
|
|
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
|
|
outoflecture = Set.filter (\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 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. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet
|
|
i18nWidgetFile :: FilePath -> Q Exp
|
|
i18nWidgetFile =
|
|
-- TODO write code to distinguish languages here
|
|
widgetFile . (</> "de") |