174 lines
6.9 KiB
Haskell
174 lines
6.9 KiB
Haskell
module Handler.Utils
|
||
( module Handler.Utils
|
||
) where
|
||
|
||
import Import
|
||
|
||
import Utils.Lens
|
||
|
||
import qualified Data.Text as T
|
||
-- import qualified Data.Set (Set)
|
||
import qualified Data.Set as Set
|
||
import Data.CaseInsensitive (original)
|
||
-- import qualified Data.CaseInsensitive as CI
|
||
|
||
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 System.Directory (listDirectory)
|
||
import System.FilePath.Posix (takeBaseName)
|
||
|
||
import qualified Data.List as List
|
||
import qualified Data.List.NonEmpty as NonEmpty
|
||
|
||
|
||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||
downloadFiles = do
|
||
mauth <- liftHandlerT maybeAuth
|
||
case mauth of
|
||
Just (Entity _ User{..}) -> return userDownloadFiles
|
||
Nothing -> do
|
||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||
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 -- ^ 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 :: 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. @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" </> 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 $ 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)|]
|