chore(letter): print certificates linked to tutorium

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
+        rcvr <- requireAuth
-        addMessageI Error MsgErrorUnknownFormAction
+        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

src/Utils/Print/CourseCertificate.hs

@@ -0,0 +1,85 @@
+-- SPDX-FileCopyrightText: 2023 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.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{..}

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}}
+%\setlength{\oddsidemargin}{\useplength{toaddrhpos}}
-\addtolength{\oddsidemargin}{-1in}
+%\addtolength{\oddsidemargin}{-1in}
-\setlength{\textwidth}{\useplength{firstheadwidth}}
+%\setlength{\textwidth}{\useplength{firstheadwidth}}
 
 \usepackage[absolute,quiet,overlay]{textpos}%,showboxes
 \setlength{\TPHorizModule}{1mm}