From 2cdc5530ad48c1dc2aea5e0006fbc5701e90ebcd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 8 Nov 2022 18:05:50 +0100 Subject: [PATCH] chore(i18n): working on i18nHamletFile --- src/Foundation/Navigation.hs | 2 +- src/Handler/Admin/Test.hs | 20 ++++++++++++-- src/Handler/Utils/DateTime.hs | 8 +++++- src/Handler/Utils/I18n.hs | 24 ++++++++++++++-- src/Handler/Utils/Mail.hs | 11 ++------ src/Handler/Utils/Users.hs | 14 ++++++++++ src/Jobs/Handler/SendTestEmail.hs | 11 ++++++-- src/Utils/Print.hs | 46 +++++++++++++++++++++++++++++++ 8 files changed, 119 insertions(+), 17 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9f247fc1f..ae285ae5c 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -653,7 +653,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , return $ NavFooter NavLink { navLabel = MsgMenuImprint - , navRoute = LegalR :#: ("imprint" :: Text) + , navRoute = LegalR :#: ("imprint" :: Text) -- neue Route, dort redirect "http://" , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 282f501d7..3b077240e 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -22,10 +22,14 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Text.Pandoc as P -import qualified Text.Pandoc.PDF as P +import qualified Text.Pandoc as P +import qualified Text.Pandoc.PDF as P import qualified Text.Pandoc.Builder as P +-- just to test i18nHamlet +import Text.Hamlet +-- import Handler.Utils.I18n + import Handler.Admin.Test.Download (testDownload) @@ -207,6 +211,10 @@ postAdminTestR = do testDownloadWidget <- testDownload + testHamlet1 <- withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet") + --let testHamlet2 = $(i18nHamletFile "test") + let testHamlet2 = testHamlet1 + let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] siteLayout locallyDefinedPageHeading $ do -- defaultLayout $ do @@ -276,6 +284,14 @@ postAdminTestR = do ^{testDownloadWidget} |] + [whamlet| +
+

Test i18nHamlet 1 + #{testHamlet1} +
+

Test i18nHamlet 2 + #{testHamlet2} + |] i18n $ MsgPrintDebugForStupid "DebugForStupid" diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 09c605930..c26edd1ec 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -14,7 +14,7 @@ module Handler.Utils.DateTime , formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTimeRange, formatTimeRangeW, formatTimeRangeMail , getTimeLocale, getDateTimeFormat - , getDateTimeFormatter + , getDateTimeFormatter, getDateTimeFormatterUser , validDateTimeFormats, dateTimeFormatOptions , addLocalDays , addDiffDaysClip, addDiffDaysRollOver @@ -133,6 +133,12 @@ getDateTimeFormatter = do formatMap <- traverse getDateTimeFormat id return $ mkDateTimeFormatter locale formatMap appTZ +getDateTimeFormatterUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (Entity User) -> m DateTimeFormatter +getDateTimeFormatterUser mUser = do + locale <- getTimeLocale + formatMap <- traverse (`getDateTimeFormatUser` mUser) id + return $ mkDateTimeFormatter locale formatMap appTZ + validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon validDateTimeFormats tl SelFormatDateTime = Set.fromList $ diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index d6146036b..8cc6d45f0 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -28,7 +28,9 @@ import qualified Data.Map as Map import System.Directory (listDirectory) import Text.Hamlet (hamletFile) - +-- | Produces: let ws = \case "de" -> ; ... +-- in selectLanguage availableTranslations >>= ws l +-- D.h. Ergebnis hat Typ: MonadHandler m => m _ i18nFile :: (FilePath -> Q Exp) -> FilePath -> Q Exp i18nFile includeFile basename = do -- Construct list of available translations (@de@, @en@, ...) at compile time @@ -62,7 +64,25 @@ i18nWidgetFile :: FilePath -> Q Exp i18nWidgetFile = i18nFile widgetFile i18nHamletFile :: FilePath -> Q Exp -i18nHamletFile basename = [e|$(i18nFile (hamletFile . ("templates" ) . (<.> "hamlet")) basename) <$> getUrlRenderParams|] +i18nHamletFile basename = [e|$(i18nFile' (hamletFile . ("templates" ) . (<.> "hamlet")) basename) <$> getUrlRenderParams|] + +i18nFile' :: (FilePath -> Q Exp) -> FilePath -> Q Exp +i18nFile' includeFile 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)) . nubOrd $ 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 . includeFile $ "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' >>= withUrlRenderer . $(varE ws)|] + + i18nWidgetFiles :: FilePath -> Q Exp i18nWidgetFiles basename = do diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 810d6e095..c375ee914 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -15,6 +15,7 @@ import Import import Handler.Utils.Pandoc import Handler.Utils.Files import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? +import Handler.Utils.Users (getReceivers) import qualified Data.CaseInsensitive as CI @@ -55,14 +56,8 @@ userMailT :: ( MonadHandler m , MonadUnliftIO m ) => UserId -> MailT m () -> m () userMailT uid mAct = do - (underling, receivers) <- liftHandler . runDB $ do - underling <- getJustEntity uid - superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] - let superIds = userSupervisorSupervisor . entityVal <$> superVs - supers <- if null superIds then pure [underling] else selectList [UserId <-. superIds] [] - return (underling, if null supers then [underling] else supers) - let undercopy = uid `elem` (entityKey <$> receivers) - undername = underling ^. _userDisplayName -- nameHtml' underling + (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid + let undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|

_{MsgMailSupervisedNote} diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index afb2d1d0c..d75f41301 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -14,6 +14,7 @@ module Handler.Utils.Users , assimilateUser , userPrefersEmail, userPrefersLetter , abbrvName + , getReceivers ) where import Import @@ -69,6 +70,19 @@ userPrefersLetter User{..} userPrefersEmail :: User -> Bool userPrefersEmail = not . userPrefersLetter +getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) +getReceivers uid = do + underling <- getJustEntity uid + superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] + let superIds = userSupervisorSupervisor . entityVal <$> superVs + if null superIds + then return (underling, [underling], True) + else do + supers <- selectList [UserId <-. superIds] [] + if null supers then return (underling, [underling], True) + else + return (underling, supers, uid `elem` (entityKey <$> supers)) + computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 5c84df9e8..096b3b7ab 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -12,6 +12,7 @@ import Handler.Utils.Mail import Handler.Utils.DateTime import Text.Hamlet -- import Handler.Utils.I18n +-- import Text.Blaze.Internal dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do @@ -53,6 +54,10 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail FRADrive |] addHtmlMarkdownAlternatives' "part3" trdmsg - -- let test = $(i18nHamletFile "test") - -- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup - + -- Html == Markup == MarkupM () + --test <- liftHandler $ withUrlRenderer $(i18nHamletFile "test") + test :: Html <- liftHandler $ withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet") + addHtmlMarkdownAlternatives test + -- + --test2 <- liftHandler $(i18nHamletFile "test") + --addHtmlMarkdownAlternatives test2 \ No newline at end of file diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 1bbac1544..be49ea741 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -304,6 +304,52 @@ sendLetter' _ = do -} +{- Probably not needed:} +data SomeUserTime where + SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime + +data ProtoMeta = IsMeta P.MetaValue + | IsTime SomeUserTime + +convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue +convertProto _ (IsMeta v) = v +convertProto f (IsTime t) = P.toMetaValue $ f t +-} + +class MDLetter l where + letterMeta :: l -> Languages -> DateTimeFormatter -> P.Meta + getTemplate :: Proxy l -> Text -- l -> Text might actually be easier to handle? + +data LetterRenewQualification = LetterRenewQualification + { lmsLogin :: LmsIdent + , lmsPin :: Text + , qualExpiry :: Day + , qualDuration :: Maybe Int + } + deriving (Eq, Show) + +instance MDLetter LetterRenewQualification where + getTemplate _ = templateRenewal + letterMeta LetterRenewQualification{..} _langs DateTimeFormatter{..} = mkMeta + [ toMeta "login" lmsIdent + , toMeta "pin" lmsPin + , toMeta "expiry" (format SelFormatDate qualExpiry) + , mbMeta "validduration" (show <$> qualDuration) + , toMeta "url-text" lmsUrl + , toMeta "url" lmsUrlLogin + ] + where + lmsUrl = "https://drive.fraport.de" + lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent + lmsIdent = getLmsIdent lmsLogin + +{- +-- sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m (?) +sendEmailOrLetter recipient letter = do + (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid + forM receivers $ \Entity +-} + ----------------------------- -- Typed Process Utilities --