chore(i18n): working on i18nHamletFile

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

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          as P
-import qualified Text.Pandoc.PDF    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|
+      <section>
+        <h2>Test i18nHamlet 1
+        #{testHamlet1}
+      <section>
+        <h2>Test i18nHamlet 2
+        #{testHamlet2}
+    |]
     i18n $ MsgPrintDebugForStupid "DebugForStupid"
 
 

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 $

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" -> <includeFile> <de-file-name>; ...
+--             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

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, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
-    underling <- getJustEntity uid
+  let undername = underling ^. _userDisplayName -- nameHtml' underling
-    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
       undermail = CI.original $ underling ^. _userEmail
       infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
             <h2>_{MsgMailSupervisedNote}

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

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")
+  -- Html == Markup == MarkupM ()
-  -- addHtmlMarkdownAlternatives' "addTest" (test :: Html) --  Text.Blaze.Internal.MarkupM  Text.Blaze.Internal.Markup
+  --test <- liftHandler $ withUrlRenderer $(i18nHamletFile "test")
-
+  test :: Html <- liftHandler $ withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
+  addHtmlMarkdownAlternatives test
+  -- 
+  --test2 <- liftHandler $(i18nHamletFile "test")
+  --addHtmlMarkdownAlternatives test2

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 --