diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index ae3330ba3..b66527596 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -11,6 +11,7 @@ module Handler.Tutorial.Users import Import import Utils.Form +import Utils.Print import Handler.Utils import Handler.Utils.Course import Handler.Utils.Tutorial @@ -20,7 +21,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map - +import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) @@ -57,13 +58,13 @@ data TutorialUserActionData deriving (Eq, Ord, Read, Show, Generic) -getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do showSex <- getShowSex - (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do + (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays @@ -118,14 +119,23 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) - return (tut, table, qualifications) + return (tutEnt, table, qualifications) let courseQids = Set.fromList (entityKey <$> qualifications) formResult participantRes $ \case - (TutorialUserPrintQualificationData{..}, _selectedUsers) + (TutorialUserPrintQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - -- TODO Continue here - addMessageI Error MsgErrorUnknownFormAction + rcvr <- requireAuth + letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers + now <- liftIO getCurrentTime + case letters of + [l] -> do + encRcvr <- encrypt $ entityKey rcvr + apcIdent <- letterApcIdent l encRcvr now + renderLetter rcvr l apcIdent >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now + _ -> addMessageI Error MsgErrorUnknownFormAction (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -158,6 +168,7 @@ postTUsersR tid ssh csh tutn = do return user let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName - siteLayoutMsg heading $ do + html <- siteLayoutMsg heading $ do setTitleI heading $(widgetFile "tutorial-participants") + return $ toTypedContent html diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs new file mode 100644 index 000000000..5a6ad5482 --- /dev/null +++ b/src/Utils/Print/CourseCertificate.hs @@ -0,0 +1,85 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print.CourseCertificate where + +import Import + +-- import Data.Char as Char +-- import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import Data.FileEmbed (embedFile) + +import Utils.Print.Letters +import Handler.Utils.Profile + +data LetterCourseCertificate = LetterCourseCertificate + { ccCourseId :: CourseId + , ccCourseName :: Text + -- , ccTutorialName :: Text + , ccCourseContent :: Maybe [Text] + , ccCourseBegin :: Maybe Day + , ccCourseEnd :: Maybe Day + , ccCourseLang :: Maybe Lang -- maybe fix language to fit course content language + , ccParticipant :: UserDisplayName + , ccFraNumber :: Maybe Text + , ccFraDepartment :: Maybe Text + , ccCompany :: Maybe Text + } + deriving (Eq, Show) + + +instance MDLetter LetterCourseCertificate where + encrypPDFfor _ = NoPassword + getLetterKind _ = Plain + getLetterEnvelope _ = 'c' + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") + + letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = + mkMeta + [ toMeta "participant" ccParticipant + , mbMeta "fra-number" ccFraNumber + , mbMeta "fra-department" ccFraDepartment + , mbMeta "company" ccCompany + , toMeta "course-name" ccCourseName + , mbMeta "course-content" ccCourseContent + , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) + , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) + , toMeta "lang" (fromMaybe lang ccCourseLang) + ] + + getPJId LetterCourseCertificate{..} = + PrintJobIdentification + { pjiName = "Certificate" + , pjiApcAcknowledge = "cc-" <> ccCourseName + , pjiRecipient = Nothing + , pjiSender = Nothing + , pjiCourse = Just ccCourseId + , pjiQualification = Nothing + , pjiLmsUser = Nothing + } + + +makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) +makeCourseCertificates tut ccCourseLang participants = do + let ccCourseId = tut ^. _tutorialCourse + Course{courseName, courseDescription} <- get404 ccCourseId + let ccCourseName = CI.original courseName + ccCourseContent = html2textlines <$> courseDescription + (ccCourseBegin, ccCourseEnd) = occurrencesBounds $ tut ^. _tutorialTime + forM participants $ \uid -> do + User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid + (ccFraNumber, ccFraDepartment, ccCompany) <- + if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber + then + return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) + else do + usrComp <- selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyId] + comp <- forM usrComp (get . userCompanyCompany . entityVal) + let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible + return (Nothing, Nothing, res) + return LetterCourseCertificate{..} diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index ba833c37b..7d3bf4316 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -1,8 +1,9 @@ %Based upon https://github.com/benedictdudel/pandoc-letter-din5008 \documentclass[ paper=A4, + version=last, firstfoot=false % first-page footer -]{scrlttr2} +]{scrartcl} \PassOptionsToPackage{hyphens}{url} \PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} @@ -84,9 +85,9 @@ $endif$ \usepackage{enumitem} -\setlength{\oddsidemargin}{\useplength{toaddrhpos}} -\addtolength{\oddsidemargin}{-1in} -\setlength{\textwidth}{\useplength{firstheadwidth}} +%\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +%\addtolength{\oddsidemargin}{-1in} +%\setlength{\textwidth}{\useplength{firstheadwidth}} \usepackage[absolute,quiet,overlay]{textpos}%,showboxes \setlength{\TPHorizModule}{1mm}