feat(letter): allow printing of multiple course certificates at once
This commit is contained in:
parent
5f536864a5
commit
768f03f672
@ -124,21 +124,22 @@ postTUsersR tid ssh csh tutn = do
|
||||
(TutorialUserPrintQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
rcvr <- requireAuth
|
||||
encRcvr <- encrypt $ entityKey rcvr
|
||||
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
|
||||
now <- liftIO getCurrentTime
|
||||
case letters of
|
||||
[l] -> do
|
||||
encRcvr <- encrypt $ entityKey rcvr
|
||||
apcIdent <- letterApcIdent l encRcvr now
|
||||
let fName = letterFileName l
|
||||
renderLetter rcvr l apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now
|
||||
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
||||
-- let typePDF :: ContentType
|
||||
-- typePDF = "application/pdf"
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
_ -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
|
||||
Just aletter -> do
|
||||
now <- liftIO getCurrentTime
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
let fName = letterFileName aletter
|
||||
renderLetters rcvr letters apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now
|
||||
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
||||
-- let typePDF :: ContentType
|
||||
-- typePDF = "application/pdf"
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
|
||||
11
src/Utils.hs
11
src/Utils.hs
@ -845,6 +845,11 @@ toNothing = const Nothing
|
||||
toNothingS :: String -> Maybe b
|
||||
toNothingS = const Nothing
|
||||
|
||||
-- | change second of maybe pair to Nothing, if both are Just and equal
|
||||
eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a)
|
||||
eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing)
|
||||
eq2nothing p = p
|
||||
|
||||
-- replaced by a more general formulation, see canonical
|
||||
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
||||
-- null2nothing (Just x) | null x = Nothing
|
||||
@ -1297,6 +1302,12 @@ maxLength :: ( Integral n
|
||||
-- ^ @maxLegth n xs = length xs <= n@
|
||||
maxLength l = not . minLength (succ l)
|
||||
|
||||
-- anyone :: (Foldable t) => t a -> Maybe a
|
||||
-- | return any single element from a foldable, if it is not null
|
||||
anyone :: (Foldable t, Alternative f) => t a -> f a
|
||||
anyone = Fold.foldr ((<|>).pure) empty
|
||||
|
||||
|
||||
------------
|
||||
-- Writer --
|
||||
------------
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
|
||||
module Utils.Print
|
||||
( renderLetter -- used for generating letter pdfs
|
||||
, renderLetters
|
||||
, sendEmailOrLetter -- directly print or sends by email
|
||||
, printLetter -- always send a letter
|
||||
, letterApcIdent -- create acknowledge string for APC
|
||||
@ -107,7 +108,7 @@ import Utils.Print.CourseCertificate
|
||||
|
||||
|
||||
-- | read and writes markdown, applying it as its own template to apply meta
|
||||
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
|
||||
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc)
|
||||
mdTemplating template meta = runExceptT $ do
|
||||
let readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
, P.readerStripComments = True
|
||||
@ -117,21 +118,20 @@ mdTemplating template meta = runExceptT $ do
|
||||
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, P.writerTemplate = Just tmpl
|
||||
}
|
||||
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
|
||||
$ addMeta meta doc
|
||||
ExceptT . pure . P.runPure $ do
|
||||
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
|
||||
P.readMarkdown readerOpts md_txt
|
||||
|
||||
|
||||
-- | creates a PDF using a LaTeX template
|
||||
pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
|
||||
pdfLaTeX lk meta md = do
|
||||
pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
|
||||
pdfLaTeX lk doc = do
|
||||
e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
|
||||
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
|
||||
let readerOpts = def { P.readerExtensions = P.pandocExtensions }
|
||||
writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, P.writerTemplate = Just tmpl }
|
||||
doc <- P.readMarkdown readerOpts md
|
||||
makePDF writerOpts
|
||||
$ appMeta setIsDeFromLang
|
||||
$ addMeta meta doc
|
||||
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, P.writerTemplate = Just tmpl }
|
||||
makePDF writerOpts $ appMeta setIsDeFromLang doc
|
||||
|
||||
|
||||
|
||||
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
|
||||
@ -151,9 +151,38 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
|
||||
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
|
||||
]
|
||||
e_md <- mdTemplating tmpl meta
|
||||
result <- actRight e_md $ pdfLaTeX kind meta
|
||||
result <- actRight e_md $ pdfLaTeX kind
|
||||
return $ over _Left P.renderError result
|
||||
|
||||
-- TODO: apcIdent does not make sense for multiple letters
|
||||
renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)
|
||||
renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
|
||||
| Just l <- anyone mdls = 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
|
||||
kind = getLetterKind $ pure l
|
||||
|
||||
templateCombine _ err@Left{} = pure err
|
||||
templateCombine mdl (Right doc1) =
|
||||
let tmpl = getTemplate mdl
|
||||
meta = addApcIdent apcIdent
|
||||
<> letterMeta mdl formatter lang rcvrEnt
|
||||
<> mkMeta
|
||||
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
|
||||
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
|
||||
]
|
||||
in mdTemplating tmpl meta >>= \case
|
||||
err@Left{} -> pure err
|
||||
Right doc2 -> pure $ Right $ doc1 <> doc2
|
||||
|
||||
doc <- foldrM templateCombine (Right mempty) mdls
|
||||
result <- actRight doc $ pdfLaTeX kind
|
||||
return $ over _Left P.renderError result
|
||||
| otherwise = return $ Left "renderLetters received empty set of letters"
|
||||
|
||||
|
||||
---------------
|
||||
|
||||
@ -80,8 +80,7 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName
|
||||
, courseSchool = CI.original . unSchoolKey -> ccCourseSchool
|
||||
, courseDescription = fmap html2textlines -> ccCourseContent
|
||||
} <- get404 ccCourseId
|
||||
let (ccCourseBegin, ccCourseEnd') = occurrencesBounds occurrences
|
||||
ccCourseEnd = bool ccCourseEnd' Nothing $ ccCourseBegin == ccCourseEnd
|
||||
let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds occurrences
|
||||
forM participants $ \uid -> do
|
||||
User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid
|
||||
(ccFraNumber, ccFraDepartment, ccCompany) <-
|
||||
|
||||
@ -79,4 +79,6 @@ $else$
|
||||
**English version is not yet implemened.**
|
||||
TODO
|
||||
|
||||
$endif$
|
||||
$endif$
|
||||
|
||||
\clearpage
|
||||
Loading…
Reference in New Issue
Block a user