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
|
||||
TutorialUserDeregister: Vom Tutorium Abmelden
|
||||
TutorialUserSendMail: Mitteilung verschicken
|
||||
TutorialUserPrintQualification: Zertifikat drucken
|
||||
TutorialUserGrantQualification: Qualifikation vergeben
|
||||
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
|
||||
|
||||
@ -45,6 +45,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
|
||||
|
||||
TutorialUserDeregister: Deregister from tutorial
|
||||
TutorialUserSendMail: Send mail
|
||||
TutorialUserPrintQualification: Print certificate
|
||||
TutorialUserGrantQualification: Grant Qualification
|
||||
TutorialUserRenewQualification: Renew Qualification
|
||||
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
|
||||
|
||||
@ -29,7 +29,8 @@ import Handler.Course.Users
|
||||
|
||||
|
||||
data TutorialUserAction
|
||||
= TutorialUserRenewQualification
|
||||
= TutorialUserPrintQualification
|
||||
| TutorialUserRenewQualification
|
||||
| TutorialUserGrantQualification
|
||||
| TutorialUserSendMail
|
||||
| TutorialUserDeregister
|
||||
@ -41,12 +42,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||
|
||||
data TutorialUserActionData
|
||||
= TutorialUserRenewQualificationData
|
||||
= TutorialUserPrintQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
}
|
||||
| TutorialUserRenewQualificationData
|
||||
{ tuQualification :: QualificationId }
|
||||
| TutorialUserGrantQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
, tuValidUntil :: Day
|
||||
}
|
||||
}
|
||||
| TutorialUserSendMailData
|
||||
| TutorialUserDeregisterData{}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -101,7 +105,11 @@ postTUsersR tid ssh csh tutn = do
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserRenewQualification
|
||||
[ ( TutorialUserPrintQualification
|
||||
, TutorialUserPrintQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
@ -109,7 +117,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
||||
@ -120,6 +128,10 @@ postTUsersR tid ssh csh tutn = do
|
||||
|
||||
let courseQids = Set.fromList (entityKey <$> qualifications)
|
||||
formResult participantRes $ \case
|
||||
(TutorialUserPrintQualificationData{..}, _selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- TODO Continue here
|
||||
addMessageI Error MsgErrorUnknownFormAction
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
@ -142,7 +154,8 @@ postTUsersR tid ssh csh tutn = do
|
||||
]
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
_other -> addMessageI Error MsgErrorUnknownFormAction
|
||||
_other ->
|
||||
addMessageI Error MsgErrorUnknownFormAction
|
||||
|
||||
tutors <- runDB $ E.select $ do
|
||||
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
||||
|
||||
@ -23,16 +23,16 @@ module Utils.Print
|
||||
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.Foldable as Fold
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Control.Monad.Except
|
||||
import Import hiding (embedFile)
|
||||
import Data.FileEmbed (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 qualified Text.Pandoc.PDF as P
|
||||
-- import qualified Text.Pandoc.Builder as P
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
@ -42,10 +42,14 @@ 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.Widgets (nameHtml')
|
||||
import Handler.Utils.Avs (updateReceivers)
|
||||
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?
|
||||
|
||||
{- 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 --
|
||||
-------------------------
|
||||
@ -296,15 +206,6 @@ pdfLetter md meta = do
|
||||
-- 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
|
||||
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 recipient letter = do
|
||||
(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
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user