chore(print): prepare modules for more letters
This commit is contained in:
parent
5eb14c8512
commit
32d56e30cc
@ -44,6 +44,7 @@ TutorCorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor:in für
|
|||||||
TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium-Teilnehmer:in" "Tutorium-Teilnehmer:innen" } abgemeldet
|
TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium-Teilnehmer:in" "Tutorium-Teilnehmer:innen" } abgemeldet
|
||||||
TutorialUserDeregister: Vom Tutorium Abmelden
|
TutorialUserDeregister: Vom Tutorium Abmelden
|
||||||
TutorialUserSendMail: Mitteilung verschicken
|
TutorialUserSendMail: Mitteilung verschicken
|
||||||
|
TutorialUserPrintQualification: Zertifikat drucken
|
||||||
TutorialUserGrantQualification: Qualifikation vergeben
|
TutorialUserGrantQualification: Qualifikation vergeben
|
||||||
TutorialUserRenewQualification: Qualifikation regulär verlängern
|
TutorialUserRenewQualification: Qualifikation regulär verlängern
|
||||||
TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
|
TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
|
||||||
|
|||||||
@ -45,6 +45,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
|
|||||||
|
|
||||||
TutorialUserDeregister: Deregister from tutorial
|
TutorialUserDeregister: Deregister from tutorial
|
||||||
TutorialUserSendMail: Send mail
|
TutorialUserSendMail: Send mail
|
||||||
|
TutorialUserPrintQualification: Print certificate
|
||||||
TutorialUserGrantQualification: Grant Qualification
|
TutorialUserGrantQualification: Grant Qualification
|
||||||
TutorialUserRenewQualification: Renew Qualification
|
TutorialUserRenewQualification: Renew Qualification
|
||||||
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
|
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
|
||||||
|
|||||||
@ -29,7 +29,8 @@ import Handler.Course.Users
|
|||||||
|
|
||||||
|
|
||||||
data TutorialUserAction
|
data TutorialUserAction
|
||||||
= TutorialUserRenewQualification
|
= TutorialUserPrintQualification
|
||||||
|
| TutorialUserRenewQualification
|
||||||
| TutorialUserGrantQualification
|
| TutorialUserGrantQualification
|
||||||
| TutorialUserSendMail
|
| TutorialUserSendMail
|
||||||
| TutorialUserDeregister
|
| TutorialUserDeregister
|
||||||
@ -41,7 +42,10 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
|||||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||||
|
|
||||||
data TutorialUserActionData
|
data TutorialUserActionData
|
||||||
= TutorialUserRenewQualificationData
|
= TutorialUserPrintQualificationData
|
||||||
|
{ tuQualification :: QualificationId
|
||||||
|
}
|
||||||
|
| TutorialUserRenewQualificationData
|
||||||
{ tuQualification :: QualificationId }
|
{ tuQualification :: QualificationId }
|
||||||
| TutorialUserGrantQualificationData
|
| TutorialUserGrantQualificationData
|
||||||
{ tuQualification :: QualificationId
|
{ tuQualification :: QualificationId
|
||||||
@ -101,7 +105,11 @@ postTUsersR tid ssh csh tutn = do
|
|||||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||||
acts = Map.fromList $
|
acts = Map.fromList $
|
||||||
(if null qualifications then mempty else
|
(if null qualifications then mempty else
|
||||||
[ ( TutorialUserRenewQualification
|
[ ( TutorialUserPrintQualification
|
||||||
|
, TutorialUserPrintQualificationData
|
||||||
|
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||||
|
)
|
||||||
|
, ( TutorialUserRenewQualification
|
||||||
, TutorialUserRenewQualificationData
|
, TutorialUserRenewQualificationData
|
||||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||||
)
|
)
|
||||||
@ -120,6 +128,10 @@ postTUsersR tid ssh csh tutn = do
|
|||||||
|
|
||||||
let courseQids = Set.fromList (entityKey <$> qualifications)
|
let courseQids = Set.fromList (entityKey <$> qualifications)
|
||||||
formResult participantRes $ \case
|
formResult participantRes $ \case
|
||||||
|
(TutorialUserPrintQualificationData{..}, _selectedUsers)
|
||||||
|
| tuQualification `Set.member` courseQids -> do
|
||||||
|
-- TODO Continue here
|
||||||
|
addMessageI Error MsgErrorUnknownFormAction
|
||||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||||
| tuQualification `Set.member` courseQids -> do
|
| tuQualification `Set.member` courseQids -> do
|
||||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||||
@ -142,7 +154,8 @@ postTUsersR tid ssh csh tutn = do
|
|||||||
]
|
]
|
||||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
_other -> addMessageI Error MsgErrorUnknownFormAction
|
_other ->
|
||||||
|
addMessageI Error MsgErrorUnknownFormAction
|
||||||
|
|
||||||
tutors <- runDB $ E.select $ do
|
tutors <- runDB $ E.select $ do
|
||||||
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
||||||
|
|||||||
@ -23,16 +23,16 @@ module Utils.Print
|
|||||||
import Data.Char (isSeparator)
|
import Data.Char (isSeparator)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Foldable as Fold
|
-- import qualified Data.Foldable as Fold
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Import hiding (embedFile)
|
import Import hiding (embedFile)
|
||||||
import Data.FileEmbed (embedFile)
|
-- import Data.FileEmbed (embedFile)
|
||||||
|
|
||||||
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
|
-- import qualified Text.Pandoc.Builder as P
|
||||||
|
|
||||||
import Text.Hamlet
|
import Text.Hamlet
|
||||||
|
|
||||||
@ -42,10 +42,14 @@ import System.Process.Typed -- for calling pdftk for pdf encryption
|
|||||||
import Handler.Utils.Users
|
import Handler.Utils.Users
|
||||||
import Handler.Utils.DateTime
|
import Handler.Utils.DateTime
|
||||||
import Handler.Utils.Mail
|
import Handler.Utils.Mail
|
||||||
import Handler.Utils.Widgets (nameHtml, nameHtml')
|
import Handler.Utils.Widgets (nameHtml')
|
||||||
import Handler.Utils.Avs (updateReceivers)
|
import Handler.Utils.Avs (updateReceivers)
|
||||||
import Jobs.Handler.SendNotification.Utils
|
import Jobs.Handler.SendNotification.Utils
|
||||||
|
|
||||||
|
import Utils.Print.Letters
|
||||||
|
import Utils.Print.RenewQualification
|
||||||
|
|
||||||
|
|
||||||
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
|
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
|
||||||
|
|
||||||
{- Recall:
|
{- Recall:
|
||||||
@ -56,100 +60,6 @@ import Jobs.Handler.SendNotification.Utils
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
|
||||||
-- Hardcoded Templates --
|
|
||||||
-------------------------
|
|
||||||
|
|
||||||
templateRenewal :: Text
|
|
||||||
templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
|
|
||||||
|
|
||||||
templateDIN5008 :: Text
|
|
||||||
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
|
|
||||||
|
|
||||||
|
|
||||||
----------------------
|
|
||||||
-- Pandoc Functions --
|
|
||||||
----------------------
|
|
||||||
-- Either I don't understand how pandoc works or
|
|
||||||
-- I don't understand why these are not included
|
|
||||||
|
|
||||||
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
|
|
||||||
compileTemplate tmpl = do
|
|
||||||
let partialPath = "" -- no partials used, see Text.DocTemplates
|
|
||||||
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
|
|
||||||
liftEither $ str2pandocError mbTemplate
|
|
||||||
where
|
|
||||||
str2pandocError = over _Left $ P.PandocTemplateError . pack
|
|
||||||
|
|
||||||
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
|
|
||||||
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
|
|
||||||
makePDF wopts doc = do
|
|
||||||
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
|
|
||||||
liftEither $ bs2pandocError mbPdf
|
|
||||||
where
|
|
||||||
texopts = []
|
|
||||||
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
|
|
||||||
|
|
||||||
_Meta :: Lens' P.Pandoc P.Meta
|
|
||||||
_Meta = lens mget mput
|
|
||||||
where
|
|
||||||
mget (P.Pandoc m _) = m
|
|
||||||
mput (P.Pandoc _ b) m = P.Pandoc m b
|
|
||||||
|
|
||||||
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
|
||||||
toMeta k = singletonMap k . P.toMetaValue
|
|
||||||
|
|
||||||
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
|
||||||
mbMeta = foldMap . toMeta
|
|
||||||
|
|
||||||
-- | For convenience and to avoid importing Pandoc
|
|
||||||
mkMeta :: [Map Text P.MetaValue] -> P.Meta
|
|
||||||
mkMeta = P.Meta . mconcat
|
|
||||||
|
|
||||||
-- | Modify the Meta-Block of Pandoc
|
|
||||||
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
|
||||||
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
|
||||||
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
|
|
||||||
|
|
||||||
|
|
||||||
-- TODO: applyMetas is inconvenient since we cannot have an instance
|
|
||||||
-- ToMetaValue a => ToMetaValue (Maybe a)
|
|
||||||
-- so apply Metas
|
|
||||||
|
|
||||||
-- For tests see module PandocSpec
|
|
||||||
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
|
|
||||||
applyMetas metas doc = Fold.foldr act doc metas
|
|
||||||
where
|
|
||||||
act (k, Just v) acc | notNull k = P.setMeta k v acc
|
|
||||||
act _ acc = acc
|
|
||||||
|
|
||||||
|
|
||||||
-- | Add meta to pandoc. Existing variables will be overwritten.
|
|
||||||
-- For specification, see module PandocSpec
|
|
||||||
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
|
|
||||||
addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not!
|
|
||||||
--addMeta m p = meta <> p
|
|
||||||
-- where meta = P.Pandoc m mempty
|
|
||||||
|
|
||||||
-- | Pandoc conditionals only test if a variable is set or isn't set.
|
|
||||||
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
|
|
||||||
-- and will be unset otherwise
|
|
||||||
setIsDeFromLang :: P.Meta -> P.Meta
|
|
||||||
setIsDeFromLang m
|
|
||||||
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
|
|
||||||
, isDe t = P.setMeta isde True m
|
|
||||||
| otherwise = P.deleteMeta isde m
|
|
||||||
where
|
|
||||||
isde = "is-de"
|
|
||||||
|
|
||||||
defReaderOpts :: P.ReaderOptions
|
|
||||||
defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True }
|
|
||||||
|
|
||||||
defWriterOpts :: P.Template Text -> P.WriterOptions
|
|
||||||
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
-- Readers and writers --
|
-- Readers and writers --
|
||||||
-------------------------
|
-------------------------
|
||||||
@ -296,15 +206,6 @@ pdfLetter md meta = do
|
|||||||
-- PrintJobs --
|
-- PrintJobs --
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
data PrintJobIdentification = PrintJobIdentification
|
|
||||||
{ pjiName :: Text
|
|
||||||
, pjiRecipient :: Maybe UserId
|
|
||||||
, pjiSender :: Maybe UserId
|
|
||||||
, pjiCourse :: Maybe CourseId
|
|
||||||
, pjiQualification :: Maybe QualificationId
|
|
||||||
, pjiLmsUser :: Maybe LmsIdent
|
|
||||||
}
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- DEPRECATED
|
-- DEPRECATED
|
||||||
sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
|
sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
|
||||||
@ -353,81 +254,6 @@ 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
|
|
||||||
getTemplate :: Proxy l -> Text
|
|
||||||
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
|
|
||||||
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
|
|
||||||
letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta
|
|
||||||
getPJId :: l -> PrintJobIdentification
|
|
||||||
|
|
||||||
data LetterRenewQualificationF = LetterRenewQualificationF
|
|
||||||
{ lmsLogin :: LmsIdent
|
|
||||||
, lmsPin :: Text
|
|
||||||
, qualHolder :: UserDisplayName
|
|
||||||
, qualHolderSN :: UserSurname
|
|
||||||
, qualExpiry :: Day
|
|
||||||
, qualId :: QualificationId
|
|
||||||
, qualName :: Text
|
|
||||||
, qualShort :: Text
|
|
||||||
, qualSchool :: SchoolId
|
|
||||||
, qualDuration :: Maybe Int
|
|
||||||
}
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- this type is specific to this letter to avoid code duplication for derived data or constants
|
|
||||||
data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text }
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData
|
|
||||||
letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..}
|
|
||||||
where
|
|
||||||
lmsUrl = "https://drive.fraport.de"
|
|
||||||
lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
|
|
||||||
lmsIdent = getLmsIdent lmsLogin
|
|
||||||
|
|
||||||
instance MDLetter LetterRenewQualificationF where
|
|
||||||
getTemplate _ = templateRenewal
|
|
||||||
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
|
||||||
-- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
|
|
||||||
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
|
|
||||||
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
|
||||||
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
|
|
||||||
|
|
||||||
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang =
|
|
||||||
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
|
||||||
in mkMeta
|
|
||||||
[ toMeta "login" lmsIdent
|
|
||||||
, toMeta "pin" lmsPin
|
|
||||||
, toMeta "examinee" qualHolder
|
|
||||||
, toMeta "expiry" (format SelFormatDate qualExpiry)
|
|
||||||
, mbMeta "validduration" (show <$> qualDuration)
|
|
||||||
, toMeta "url-text" lmsUrl
|
|
||||||
, toMeta "url" lmsUrlLogin
|
|
||||||
]
|
|
||||||
|
|
||||||
getPJId LetterRenewQualificationF{..} =
|
|
||||||
PrintJobIdentification
|
|
||||||
{ pjiName = "Renewal"
|
|
||||||
, pjiRecipient = Nothing -- to be filled later
|
|
||||||
, pjiSender = Nothing
|
|
||||||
, pjiCourse = Nothing
|
|
||||||
, pjiQualification = Just qualId
|
|
||||||
, pjiLmsUser = Just lmsLogin
|
|
||||||
}
|
|
||||||
|
|
||||||
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
|
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
|
||||||
sendEmailOrLetter recipient letter = do
|
sendEmailOrLetter recipient letter = do
|
||||||
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
|
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
|
||||||
|
|||||||
174
src/Utils/Print/Letters.hs
Normal file
174
src/Utils/Print/Letters.hs
Normal file
@ -0,0 +1,174 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||||
|
|
||||||
|
module Utils.Print.Letters where
|
||||||
|
|
||||||
|
-- import Import.NoModel
|
||||||
|
-- import Data.Char (isSeparator)
|
||||||
|
-- import qualified Data.Text as T
|
||||||
|
-- import qualified Data.CaseInsensitive as CI
|
||||||
|
import qualified Data.Foldable as Fold
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Import hiding (embedFile)
|
||||||
|
import Data.FileEmbed (embedFile)
|
||||||
|
|
||||||
|
import qualified Text.Pandoc as P
|
||||||
|
import qualified Text.Pandoc.PDF as P
|
||||||
|
import qualified Text.Pandoc.Builder as P
|
||||||
|
|
||||||
|
import Text.Hamlet
|
||||||
|
|
||||||
|
-- import System.Exit
|
||||||
|
-- import System.Process.Typed -- for calling pdftk for pdf encryption
|
||||||
|
|
||||||
|
-- import Handler.Utils.Users
|
||||||
|
-- import Handler.Utils.DateTime
|
||||||
|
-- import Handler.Utils.Mail
|
||||||
|
-- import Handler.Utils.Widgets (nameHtml, nameHtml')
|
||||||
|
-- import Handler.Utils.Avs (updateReceivers)
|
||||||
|
-- import Jobs.Handler.SendNotification.Utils
|
||||||
|
|
||||||
|
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------
|
||||||
|
-- Hardcoded Templates --
|
||||||
|
-------------------------
|
||||||
|
|
||||||
|
templateRenewal :: Text
|
||||||
|
templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
|
||||||
|
|
||||||
|
templateDIN5008 :: Text
|
||||||
|
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---------------
|
||||||
|
-- PrintJobs --
|
||||||
|
---------------
|
||||||
|
|
||||||
|
data PrintJobIdentification = PrintJobIdentification
|
||||||
|
{ pjiName :: Text
|
||||||
|
, pjiRecipient :: Maybe UserId
|
||||||
|
, pjiSender :: Maybe UserId
|
||||||
|
, pjiCourse :: Maybe CourseId
|
||||||
|
, pjiQualification :: Maybe QualificationId
|
||||||
|
, pjiLmsUser :: Maybe LmsIdent
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
|
||||||
|
------------------
|
||||||
|
-- Letter Class --
|
||||||
|
------------------
|
||||||
|
|
||||||
|
{- 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
|
||||||
|
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
|
||||||
|
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
|
||||||
|
letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta
|
||||||
|
getTemplate :: Proxy l -> Text
|
||||||
|
getPJId :: l -> PrintJobIdentification
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
----------------------
|
||||||
|
-- Pandoc Functions --
|
||||||
|
----------------------
|
||||||
|
-- Either I don't understand how pandoc works or
|
||||||
|
-- I don't understand why these are not included
|
||||||
|
|
||||||
|
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
|
||||||
|
compileTemplate tmpl = do
|
||||||
|
let partialPath = "" -- no partials used, see Text.DocTemplates
|
||||||
|
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
|
||||||
|
liftEither $ str2pandocError mbTemplate
|
||||||
|
where
|
||||||
|
str2pandocError = over _Left $ P.PandocTemplateError . pack
|
||||||
|
|
||||||
|
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
|
||||||
|
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
|
||||||
|
makePDF wopts doc = do
|
||||||
|
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
|
||||||
|
liftEither $ bs2pandocError mbPdf
|
||||||
|
where
|
||||||
|
texopts = []
|
||||||
|
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
|
||||||
|
|
||||||
|
_Meta :: Lens' P.Pandoc P.Meta
|
||||||
|
_Meta = lens mget mput
|
||||||
|
where
|
||||||
|
mget (P.Pandoc m _) = m
|
||||||
|
mput (P.Pandoc _ b) m = P.Pandoc m b
|
||||||
|
|
||||||
|
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
||||||
|
toMeta k = singletonMap k . P.toMetaValue
|
||||||
|
|
||||||
|
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
||||||
|
mbMeta = foldMap . toMeta
|
||||||
|
|
||||||
|
-- | For convenience and to avoid importing Pandoc
|
||||||
|
mkMeta :: [Map Text P.MetaValue] -> P.Meta
|
||||||
|
mkMeta = P.Meta . mconcat
|
||||||
|
|
||||||
|
-- | Modify the Meta-Block of Pandoc
|
||||||
|
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
||||||
|
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
||||||
|
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: applyMetas is inconvenient since we cannot have an instance
|
||||||
|
-- ToMetaValue a => ToMetaValue (Maybe a)
|
||||||
|
-- so apply Metas
|
||||||
|
|
||||||
|
-- For tests see module PandocSpec
|
||||||
|
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
|
||||||
|
applyMetas metas doc = Fold.foldr act doc metas
|
||||||
|
where
|
||||||
|
act (k, Just v) acc | notNull k = P.setMeta k v acc
|
||||||
|
act _ acc = acc
|
||||||
|
|
||||||
|
|
||||||
|
-- | Add meta to pandoc. Existing variables will be overwritten.
|
||||||
|
-- For specification, see module PandocSpec
|
||||||
|
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
|
||||||
|
addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not!
|
||||||
|
--addMeta m p = meta <> p
|
||||||
|
-- where meta = P.Pandoc m mempty
|
||||||
|
|
||||||
|
-- | Pandoc conditionals only test if a variable is set or isn't set.
|
||||||
|
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
|
||||||
|
-- and will be unset otherwise
|
||||||
|
setIsDeFromLang :: P.Meta -> P.Meta
|
||||||
|
setIsDeFromLang m
|
||||||
|
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
|
||||||
|
, isDe t = P.setMeta isde True m
|
||||||
|
| otherwise = P.deleteMeta isde m
|
||||||
|
where
|
||||||
|
isde = "is-de"
|
||||||
|
|
||||||
|
defReaderOpts :: P.ReaderOptions
|
||||||
|
defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True }
|
||||||
|
|
||||||
|
defWriterOpts :: P.Template Text -> P.WriterOptions
|
||||||
|
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
|
||||||
|
|
||||||
74
src/Utils/Print/RenewQualification.hs
Normal file
74
src/Utils/Print/RenewQualification.hs
Normal file
@ -0,0 +1,74 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||||
|
|
||||||
|
module Utils.Print.RenewQualification where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Text.Hamlet
|
||||||
|
|
||||||
|
-- import Data.Char (isSeparator)
|
||||||
|
-- import qualified Data.Text as T
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import Utils.Print.Letters
|
||||||
|
import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
|
||||||
|
|
||||||
|
|
||||||
|
data LetterRenewQualificationF = LetterRenewQualificationF
|
||||||
|
{ lmsLogin :: LmsIdent
|
||||||
|
, lmsPin :: Text
|
||||||
|
, qualHolder :: UserDisplayName
|
||||||
|
, qualHolderSN :: UserSurname
|
||||||
|
, qualExpiry :: Day
|
||||||
|
, qualId :: QualificationId
|
||||||
|
, qualName :: Text
|
||||||
|
, qualShort :: Text
|
||||||
|
, qualSchool :: SchoolId
|
||||||
|
, qualDuration :: Maybe Int
|
||||||
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
|
||||||
|
-- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants
|
||||||
|
data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text }
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData
|
||||||
|
letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..}
|
||||||
|
where
|
||||||
|
lmsUrl = "https://drive.fraport.de"
|
||||||
|
lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
|
||||||
|
lmsIdent = getLmsIdent lmsLogin
|
||||||
|
|
||||||
|
instance MDLetter LetterRenewQualificationF where
|
||||||
|
getTemplate _ = templateRenewal
|
||||||
|
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
||||||
|
-- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
|
||||||
|
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
|
||||||
|
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
||||||
|
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
|
||||||
|
|
||||||
|
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang =
|
||||||
|
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
|
||||||
|
in mkMeta
|
||||||
|
[ toMeta "login" lmsIdent
|
||||||
|
, toMeta "pin" lmsPin
|
||||||
|
, toMeta "examinee" qualHolder
|
||||||
|
, toMeta "expiry" (format SelFormatDate qualExpiry)
|
||||||
|
, mbMeta "validduration" (show <$> qualDuration)
|
||||||
|
, toMeta "url-text" lmsUrl
|
||||||
|
, toMeta "url" lmsUrlLogin
|
||||||
|
]
|
||||||
|
|
||||||
|
getPJId LetterRenewQualificationF{..} =
|
||||||
|
PrintJobIdentification
|
||||||
|
{ pjiName = "Renewal"
|
||||||
|
, pjiRecipient = Nothing -- to be filled later
|
||||||
|
, pjiSender = Nothing
|
||||||
|
, pjiCourse = Nothing
|
||||||
|
, pjiQualification = Just qualId
|
||||||
|
, pjiLmsUser = Just lmsLogin
|
||||||
|
}
|
||||||
Reference in New Issue
Block a user