From ffaaf9c86d5caa7eaec2d2bcd06bc6963310a7eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Mar 2023 17:27:57 +0000 Subject: [PATCH 01/33] feat(course): associate qualifications with courses --- models/courses.model | 7 +++++ src/Handler/Tutorial/Users.hs | 57 ++++++++++++++++++++++------------- test/Database/Fill.hs | 14 ++++++--- 3 files changed, 52 insertions(+), 26 deletions(-) diff --git a/models/courses.model b/models/courses.model index 3bfee5a1b..0d278f295 100644 --- a/models/courses.model +++ b/models/courses.model @@ -90,3 +90,10 @@ CourseUserExamOfficeOptOut school SchoolId UniqueCourseUserExamOfficeOptOut course user school deriving Generic + +CourseQualification + course CourseId + qualification QualificationId + sortOrder Int default=0 + UniqueCourseQualification course qualification + deriving Generic \ No newline at end of file diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 8ece41d3a..e01ff2223 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Tutorial.Users ( getTUsersR, postTUsersR ) where @@ -20,7 +22,8 @@ import qualified Data.Map as Map -- import qualified Data.Time.Zones as TZ -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import Handler.Course.Users @@ -54,8 +57,17 @@ getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do showSex <- getShowSex (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn - qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] + -- qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] + qualifications <- E.select $ do + (qual :& courseQual) <- + E.from $ E.table @Qualification + `E.innerJoin` E.table @CourseQualification + `E.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) + E.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid + E.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder] + pure qual now <- liftIO getCurrentTime let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur @@ -71,12 +83,12 @@ postTUsersR tid ssh csh tutn = do & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) - isInTut q = E.exists . E.from $ \tutorialParticipant -> + isInTut q = E.exists $ do + tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] - - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do @@ -87,17 +99,20 @@ postTUsersR tid ssh csh tutn = do , optionExternalValue = tshow cQualId } acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) - acts = Map.fromList - [ ( TutorialUserRenewQualification - , TutorialUserRenewQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - ) - , ( TutorialUserGrantQualification - , TutorialUserGrantQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry - ) - , ( TutorialUserSendMail, pure TutorialUserSendMailData ) + acts = Map.fromList $ + (if null qualifications then mempty else + [ ( TutorialUserRenewQualification + , TutorialUserRenewQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + ) + , ( TutorialUserGrantQualification + , TutorialUserGrantQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry + ) + ] + ) ++ + [ ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) @@ -125,11 +140,11 @@ postTUsersR tid ssh csh tutn = do addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR - tutors <- runDB $ - E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do - E.on $ tutor E.^. TutorUser E.==. user E.^. UserId - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return user + tutors <- runDB $ E.select $ do + (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User + `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return user let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName siteLayoutMsg heading $ do diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 87f3e38ae..995ae5f48 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -57,8 +57,8 @@ fillDb = do addBDays = addBusinessDays Fraport -- holiday area to use n_day n = addBDays n $ utctDay now n_day' n = now { utctDay = n_day n } - currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now - -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now + currentTerm = TermIdentifier currentYear nextTerm n = toEnum . (+n) $ fromEnum currentTerm termTime :: TermIdentifier -- ^ Term @@ -172,7 +172,7 @@ fillDb = do , userTitle = Just "Dr." , userMaxFavourites = 14 , userMaxFavouriteTerms = 4 - , userTheme = userDefaultTheme + , userTheme = ThemeSkyLove , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat @@ -402,7 +402,7 @@ fillDb = do , userTitle = Nothing , userMaxFavourites = userDefaultMaxFavourites , userMaxFavouriteTerms = userDefaultMaxFavourites - , userTheme = userDefaultTheme + , userTheme = ThemeAberdeenReds , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat @@ -786,6 +786,7 @@ fillDb = do jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight + tyear = year tid weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 @@ -816,8 +817,11 @@ fillDb = do , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True - } + } insert_ $ CourseEdit jost now c + when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2 + when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3 + when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1 insert_ Sheet { sheetCourse = c , sheetName = mkName "Sehtest" From 5eb14c85122d2511c3a3d59aafc8953bbb4563a9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Mar 2023 17:59:00 +0000 Subject: [PATCH 02/33] chore(tutorial): ensure that course qualification form actions are stll valid upon reception --- .../uniworx/categories/error/de-de-formal.msg | 2 ++ messages/uniworx/categories/error/en-eu.msg | 2 ++ src/Handler/Tutorial/Users.hs | 28 +++++++++++-------- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/categories/error/de-de-formal.msg b/messages/uniworx/categories/error/de-de-formal.msg index fc419ed73..5ebda257d 100644 --- a/messages/uniworx/categories/error/de-de-formal.msg +++ b/messages/uniworx/categories/error/de-de-formal.msg @@ -6,3 +6,5 @@ ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine S ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden. ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt. ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an. + +ErrorUnknownFormAction: Unbekannte oder ungültige Formular Aktion wurde ignoriert. \ No newline at end of file diff --git a/messages/uniworx/categories/error/en-eu.msg b/messages/uniworx/categories/error/en-eu.msg index 6d22e42db..9b3a3d83a 100644 --- a/messages/uniworx/categories/error/en-eu.msg +++ b/messages/uniworx/categories/error/en-eu.msg @@ -6,3 +6,5 @@ ErrorResponseNotFound: No page could be found under the url requested by your br ErrorResponseNotAuthenticated: To be granted access to most parts of Uni2work you need to login first. ErrorResponseBadMethod requestMethodText: Your browser can interact in multiple ways with the resources offered by Uni2work. The requested method (#{requestMethodText}) is not supported here. ErrorResponseEncrypted: In order not to reveal sensitive information further details have been encrypted. If you send a support request, please include the encrypted data listed below. + +ErrorUnknownFormAction: Unknown or invalid form action was ignored. \ No newline at end of file diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e01ff2223..8bbb02ee0 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -56,7 +56,7 @@ getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do showSex <- getShowSex - (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do + (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn -- qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] @@ -116,19 +116,22 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) - return (tut, table) + return (tut, table, qualifications) + let courseQids = Set.fromList (entityKey <$> qualifications) formResult participantRes $ \case - (TutorialUserGrantQualificationData{..}, selectedUsers) -> do - -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - today <- utctDay <$> liftIO getCurrentTime - runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing - addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers - redirect $ CTutorialR tid ssh csh tutn TUsersR - (TutorialUserRenewQualificationData{..}, selectedUsers) -> do - noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers - addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks - redirect $ CTutorialR tid ssh csh tutn TUsersR + (TutorialUserGrantQualificationData{..}, selectedUsers) + | tuQualification `Set.member` courseQids -> do + -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + today <- utctDay <$> liftIO getCurrentTime + runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing + addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers + redirect $ CTutorialR tid ssh csh tutn TUsersR + (TutorialUserRenewQualificationData{..}, selectedUsers) + | tuQualification `Set.member` courseQids -> do + noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers + addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) @@ -139,6 +142,7 @@ postTUsersR tid ssh csh tutn = do ] addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR + _other -> addMessageI Error MsgErrorUnknownFormAction tutors <- runDB $ E.select $ do (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User From 32d56e30cc8145abdf10aee17d722c4d40f65905 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Mar 2023 15:09:51 +0000 Subject: [PATCH 03/33] chore(print): prepare modules for more letters --- .../courses/tutorial/de-de-formal.msg | 1 + .../categories/courses/tutorial/en-eu.msg | 1 + src/Handler/Tutorial/Users.hs | 25 ++- src/Utils/Print.hs | 192 +----------------- src/Utils/Print/Letters.hs | 174 ++++++++++++++++ src/Utils/Print/RenewQualification.hs | 74 +++++++ 6 files changed, 278 insertions(+), 189 deletions(-) create mode 100644 src/Utils/Print/Letters.hs create mode 100644 src/Utils/Print/RenewQualification.hs diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 601183d85..eb030ae8c 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 4ecbb64e1..cdcf22eda 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -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"} diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 8bbb02ee0..163c8df38 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 2700c2fad..0c8e9c4f7 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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 diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs new file mode 100644 index 000000000..d3fb9ab54 --- /dev/null +++ b/src/Utils/Print/Letters.hs @@ -0,0 +1,174 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- 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 } + diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs new file mode 100644 index 000000000..3a3884683 --- /dev/null +++ b/src/Utils/Print/RenewQualification.hs @@ -0,0 +1,74 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- 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 + } \ No newline at end of file From 446ab7628663b1e73d4c4ffe88be88f78cb29708 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Mar 2023 17:45:28 +0000 Subject: [PATCH 04/33] chore(latex): rework templates for print varieties --- src/Handler/Admin/Test.hs | 1 + src/Utils/Print.hs | 97 +++++++------ src/Utils/Print/Letters.hs | 25 +++- templates/letter/din5008.latex | 24 ++-- templates/letter/din5008with_pin.latex | 182 +++++++++++++++++++++++++ templates/letter/fraport_renewal.md | 9 +- templates/letter/plain_article.latex | 105 ++++++++++++++ 7 files changed, 383 insertions(+), 60 deletions(-) create mode 100644 templates/letter/din5008with_pin.latex create mode 100644 templates/letter/plain_article.latex diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 6c9c64a47..5346c6aa9 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -10,6 +10,7 @@ module Handler.Admin.Test import Import import Utils.Print +import Utils.Print.Letters import Handler.Utils import Jobs diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 0c8e9c4f7..08ab95edc 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -5,13 +5,10 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print - ( pdfRenewal - , sendLetter, sendLetter' + ( pdfRenewal, sendLetter' -- only used for test-letters triggered in route PrintSendR , sendEmailOrLetter , encryptPDF , sanitizeCmdArg, validCmdArgument - , templateDIN5008 - , templateRenewal -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values @@ -68,40 +65,42 @@ import Utils.Print.RenewQualification -- This is a hack to allow variable interpolation within a document. -- Pandoc currently only allows interpolation within templates. -- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates -reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text -reTemplateLetter meta StoredMarkup{..} = do - tmpl <- compileTemplate strictMarkupInput - doc <- areader readerOpts strictMarkupInput - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just tmpl } - P.writeMarkdown writerOpts - $ appMeta setIsDeFromLang - $ addMeta meta doc - where - strictMarkupInput = toStrict markupInput - readerOpts = def { P.readerExtensions = P.pandocExtensions - , P.readerStripComments = True - } - -- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc - areader = case markupInputFormat of - MarkupHtml -> P.readHtml - MarkupMarkdown -> P.readMarkdown - MarkupPlaintext -> P.readMarkdown +-- reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text +-- reTemplateLetter meta StoredMarkup{..} = do +-- tmpl <- compileTemplate strictMarkupInput +-- doc <- areader readerOpts strictMarkupInput +-- let writerOpts = def { P.writerExtensions = P.pandocExtensions +-- , P.writerTemplate = Just tmpl } +-- P.writeMarkdown writerOpts +-- $ appMeta setIsDeFromLang +-- $ addMeta meta doc +-- where +-- strictMarkupInput = toStrict markupInput +-- readerOpts = def { P.readerExtensions = P.pandocExtensions +-- , P.readerStripComments = True +-- } +-- -- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc +-- areader = case markupInputFormat of +-- MarkupHtml -> P.readHtml +-- MarkupMarkdown -> P.readMarkdown +-- MarkupPlaintext -> P.readMarkdown -reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text -reTemplateLetter' meta md = do - tmpl <- compileTemplate md - doc <- P.readMarkdown readerOpts md - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just tmpl } - P.writeMarkdown writerOpts - $ appMeta setIsDeFromLang - $ addMeta meta doc - where - readerOpts = def { P.readerExtensions = P.pandocExtensions - , P.readerStripComments = True - } +-- reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text +-- reTemplateLetter' meta md = do +-- tmpl <- compileTemplate md +-- doc <- P.readMarkdown readerOpts md +-- let writerOpts = def { P.writerExtensions = P.pandocExtensions +-- , P.writerTemplate = Just tmpl } +-- P.writeMarkdown writerOpts +-- $ appMeta setIsDeFromLang +-- $ addMeta meta doc +-- where +-- readerOpts = def { P.readerExtensions = P.pandocExtensions +-- , P.readerStripComments = True +-- } + +-- | read and writes markdown, applying it as its own template to apply meta mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions @@ -179,7 +178,7 @@ mdRenewal meta = runExceptT $ do $ addMeta meta doc --- | combines 'mdRenewal' and 'pdfDIN5008' +-- | combines 'mdRenewal' and 'pdfDIN5008'; only user in PrintSendR Test Handler pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString) pdfRenewal meta = do e_txt <- mdRenewal' meta @@ -187,27 +186,47 @@ pdfRenewal meta = do result <- actRight e_txt $ pdfDIN5008 meta return $ over _Left P.renderError result +{- -- | like pdfRenewal but without caching pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString pdfRenewal' meta = do doc <- reTemplateLetter' meta templateRenewal pdfDIN5008' meta doc +-} -- Generic Version -pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString) +pdfLetter :: Text -> P.Meta -> Handler (Either Text LBS.ByteString) pdfLetter md meta = do e_txt <- mdTemplating md meta result <- actRight e_txt $ pdfDIN5008 meta return $ over _Left P.renderError result +renderLetter :: (MDLetter l) => User -> l -> Handler (Either Text LBS.ByteString) +renderLetter rcvr mdl = do + now <- liftIO getCurrentTime + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + tmpl = getTemplate $ pure mdl + meta = letterMeta mdl formatter lang + <> mkMeta + [ toMeta "paper" ("TODO"::Text) -- TODO continue here + , toMeta "printid" ("TODO"::Text) + , toMeta "lang" lang + , toMeta "date" $ format SelFormatDate now + , toMeta "rcvr-name" $ rcvr & userDisplayName + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr + --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + ] + pdfLetter tmpl meta + --------------- -- PrintJobs -- --------------- --- DEPRECATED +-- Only used in print-test-handler for PrintSendR sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = sendLetter pdf PrintJobIdentification diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index d3fb9ab54..1f6459e48 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -42,12 +42,33 @@ import Text.Hamlet -- Hardcoded Templates -- ------------------------- -templateRenewal :: Text -templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") +data LetterKind = Din5008 -- scrlttr2: Standard postal letter with address field, expects peprinted FraportLogo + | PinLetter -- Like Din5008, but for special paper with a protected pin field + | Plain -- scrartcl: Empty, expects empty paper with no preprints + | PlainLogo -- Like plain, but expects to be printed on paper with Logo + -- | Logo -- Like plain, but prints Fraport Logo in the upper right corner + deriving (Eq, Show) + +templateLatex :: LetterKind -> Text +templateLatex = + let + tDin5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") + tPinLetter = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin.latex") + tPlain = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/plain_article.latex") + in \case + PinLetter -> tPinLetter + Din5008 -> tDin5008 + PlainLogo -> tPlain + Plain -> tPlain + +-- | DEPRECATED TODO: remove templateDIN5008 :: Text templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") +templateRenewal :: Text +templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + --------------- diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 9ad2d8280..1660f2d11 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -80,7 +80,7 @@ $endif$ %\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL -\usepackage{parskip} +%\usepackage{parskip}% might be useful for pandoc tightlist \usepackage{graphics} \usepackage{xcolor} @@ -120,7 +120,11 @@ $endif$ } \setkomavar{fromphone}{$phone$} \setkomavar{fromemail}{$email$} - \setkomavar{signature}{$author$} + %if there is a handwritten signature + %\setkomavar{signature}{$author$} + %if there is no handwritten signature + \setkomavar{signature}{} + \setplength{sigbeforevskip}{-\baselineskip} \setkomavar{date}{$date$} \setkomavar{place}{$place$} @@ -143,19 +147,9 @@ $endif$ \opening{$en-opening$} $endif$ - \begin{textblock}{65}(84,232)%hpos,vpos - \textcolor{black!39}{ - \begin{labeling}{Password:} - $if(is-de)$ - \item[Benutzer:] \texttt{$login$} - \item[Passwort:] \texttt{$pin$} - $else$ - \item[User:] \texttt{$login$} - \item[Password:] \texttt{$pin$} - $endif$ - \end{labeling} - ~} - \end{textblock} + \begin{textblock}{65}(142,21)%hpos,vpos + \textcolor{white!0}{:::$paper$:::$printid$:::}% + \end{textblock} $body$ diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex new file mode 100644 index 000000000..c22e1c5c2 --- /dev/null +++ b/templates/letter/din5008with_pin.latex @@ -0,0 +1,182 @@ +%Based upon https://github.com/benedictdudel/pandoc-letter-din5008 +\documentclass[ + paper=A4, + foldmarks=BTm, % show foldmarks top, middle, bottom + foldmarks=false, % don't print foldmarks + fromalign=left, % letter head on the right + fromphone=true, % show phone number + fromemail=true, % show email + fromlogo=false, % don't show logo in letter head + version=last, % latest version of KOMA letter + pagenumber=botright, % show pagenumbers on bottom right + firstfoot=false % first-page footer +]{scrlttr2} + +\PassOptionsToPackage{hyphens}{url} +\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} +\IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available +\IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} +\hypersetup{ +$if(title-meta)$ + pdftitle={$title-meta$}, +$endif$ +$if(author-meta)$ + pdfauthor={$author-meta$}, +$endif$ +$if(lang)$ + pdflang={$lang$}, +$endif$ +$if(subject)$ + pdfsubject={$subject$}, +$endif$ +$if(keywords)$ + pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$}, +$endif$ +} +\usepackage{url} + +\usepackage{iftex} + +%\usepackage[ngerman]{babel} +$if(lang)$ +\ifLuaTeX +\usepackage[bidi=basic]{babel} +\else +\usepackage[bidi=default]{babel} +\fi +\babelprovide[main,import]{$babel-lang$} +$for(babel-otherlangs)$ +\babelprovide[import]{$babel-otherlangs$} +$endfor$ +% get rid of language-specific shorthands (see #6817): +\let\LanguageShortHands\languageshorthands +\def\languageshorthands#1{} +$endif$ + +\ifLuaTeX + \usepackage{selnolig} % disable illegal ligatures +\fi + +\ifPDFTeX + \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} + \usepackage[utf8]{inputenc} + \usepackage{textcomp} % provide euro and other symbols + \usepackage{DejaVuSansMono} % better monofont +\else + % if luatex or xetex + \usepackage{fontspec} + \setmonofont{DejaVu Sans Mono} +\fi + +$if(mathspec)$ + \ifXeTeX + \usepackage{mathspec} + \else + \usepackage{unicode-math} + \fi +$else$ + \usepackage{unicode-math} +$endif$ + +%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL + +%\usepackage{parskip}% might be useful for pandoc tightlist + +\usepackage{graphics} +\usepackage{xcolor} + +\usepackage{booktabs} +\usepackage{longtable} + +\usepackage[right]{eurosym} + +\usepackage{enumitem} + +\makeatletter + \setplength{firstheadvpos}{1.8cm} + \setplength{toaddrvpos}{5.5cm} + \setlength{\@tempskipa}{-1.2cm}% + \@addtoplength{toaddrheight}{\@tempskipa} +\makeatother + +\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +\addtolength{\oddsidemargin}{-1in} +\setlength{\textwidth}{\useplength{firstheadwidth}} + +\usepackage[absolute,quiet,overlay]{textpos}%,showboxes +\setlength{\TPHorizModule}{1mm} +\setlength{\TPVertModule}{1mm} + +\providecommand{\tightlist}{% + \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} + +\begin{document}% + \setkomavar{fromname}{$author$}% + \renewcommand*{\raggedsignature}{\raggedright}% + \setkomavar{fromaddress}{% + $for(return-address)$% + $return-address$$sep$\\ + $endfor$ + } + \setkomavar{fromphone}{$phone$} + \setkomavar{fromemail}{$email$} + %if there is a handwritten signature + %\setkomavar{signature}{$author$} + %if there is no handwritten signature + \setkomavar{signature}{} + \setplength{sigbeforevskip}{-\baselineskip} + + \setkomavar{date}{$date$} + \setkomavar{place}{$place$} + + $if(is-de)$ + \setkomavar{subject}{$de-subject$} + $else$ + \setkomavar{subject}{$en-subject$} + $endif$ + + \begin{letter}{% + $for(address)$ + $address$$sep$\\ + $endfor$ + } + + $if(is-de)$ + \opening{$de-opening$} + $else$ + \opening{$en-opening$} + $endif$ + + \begin{textblock}{65}(142,21)%hpos,vpos + \textcolor{white!0}{:::$paper$:::$printid$:::}% + \end{textblock} + \begin{textblock}{65}(84,232)%hpos,vpos + \textcolor{black!39}{ + \begin{labeling}{Password:} + $if(is-de)$ + \item[Benutzer:] \texttt{$login$} + \item[Passwort:] \texttt{$pin$} + $else$ + \item[User:] \texttt{$login$} + \item[Password:] \texttt{$pin$} + $endif$ + \end{labeling} + ~} + \end{textblock} + + $body$ + + $if(is-de)$ + \closing{$de-closing$} + $else$ + \closing{$en-closing$} + $endif$ + + %\ps $postskriptum$ + + $if(encludes)$ + \setkomavar*{enclseparator}{Anlage} + \encl{$encludes$} + $endif$ + \end{letter} +\end{document} diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 07978d9ed..08d2148ac 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -12,10 +12,10 @@ return-address: de-opening: Liebe Fahrberechtigungsinhaber, en-opening: Dear driver, de-closing: | - Mit freundlichen Grüßen, + Mit freundlichen Grüßen, Ihre Fahrerausbildung en-closing: | - With kind regards, + With kind regards, Your Fraport Driver Training encludes: hyperrefoptions: hidelinks @@ -29,11 +29,12 @@ lang: de-de is-de: true login: 123456 pin: abcdef +paper: pin # Emfpänger -examinee: E. M. Pfänger +examinee: P. Rüfling address: - - Musterfirma GmbH - E. M. Pfänger + - Musterfirma GmbH - Musterstraße 11 - 12345 Musterstadt ... diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex new file mode 100644 index 000000000..baab246d9 --- /dev/null +++ b/templates/letter/plain_article.latex @@ -0,0 +1,105 @@ +%Based upon https://github.com/benedictdudel/pandoc-letter-din5008 +\documentclass[ + paper=A4, + firstfoot=false % first-page footer +]{scrlttr2} + +\PassOptionsToPackage{hyphens}{url} +\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} +\IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available +\IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} +\hypersetup{ +$if(title-meta)$ + pdftitle={$title-meta$}, +$endif$ +$if(author-meta)$ + pdfauthor={$author-meta$}, +$endif$ +$if(lang)$ + pdflang={$lang$}, +$endif$ +$if(subject)$ + pdfsubject={$subject$}, +$endif$ +$if(keywords)$ + pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$}, +$endif$ +} +\usepackage{url} + +\usepackage{iftex} + +%\usepackage[ngerman]{babel} +$if(lang)$ +\ifLuaTeX +\usepackage[bidi=basic]{babel} +\else +\usepackage[bidi=default]{babel} +\fi +\babelprovide[main,import]{$babel-lang$} +$for(babel-otherlangs)$ +\babelprovide[import]{$babel-otherlangs$} +$endfor$ +% get rid of language-specific shorthands (see #6817): +\let\LanguageShortHands\languageshorthands +\def\languageshorthands#1{} +$endif$ + +\ifLuaTeX + \usepackage{selnolig} % disable illegal ligatures +\fi + +\ifPDFTeX + \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} + \usepackage[utf8]{inputenc} + \usepackage{textcomp} % provide euro and other symbols + \usepackage{DejaVuSansMono} % better monofont +\else + % if luatex or xetex + \usepackage{fontspec} + \setmonofont{DejaVu Sans Mono} +\fi + +$if(mathspec)$ + \ifXeTeX + \usepackage{mathspec} + \else + \usepackage{unicode-math} + \fi +$else$ + \usepackage{unicode-math} +$endif$ + +%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL + +%\usepackage{parskip}% might be useful for pandoc tightlist + +\usepackage{graphics} +\usepackage{xcolor} + +\usepackage{booktabs} +\usepackage{longtable} + +\usepackage[right]{eurosym} + +\usepackage{enumitem} + +\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +\addtolength{\oddsidemargin}{-1in} +\setlength{\textwidth}{\useplength{firstheadwidth}} + +\usepackage[absolute,quiet,overlay]{textpos}%,showboxes +\setlength{\TPHorizModule}{1mm} +\setlength{\TPVertModule}{1mm} + +\providecommand{\tightlist}{% + \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} + +\begin{document}% + \begin{textblock}{65}(142,21)%hpos,vpos + \textcolor{white!0}{:::$paper$:::$printid$:::}% + \end{textblock} + + $body$ + +\end{document} From b069282d0ac2170c2e8bc9b7cc11fa2da918c806 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Mar 2023 11:11:37 +0000 Subject: [PATCH 05/33] chore(term): use time range formatter --- src/Handler/Term.hs | 26 ++++++++++++-------------- src/Handler/Utils/DateTime.hs | 32 ++++++++++++++++++++------------ 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index d6047f29f..345f0d882 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -77,20 +77,18 @@ getTermShowR = do -> cell $ formatTime SelFormatDate termEnd >>= toWidget , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _) -> cell $ do - let termHolidays' = groupHolidays termHolidays - [whamlet| - $newline never -