From cfd40e0bda36e8bffb44fbd4e21bcd104e6b712c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 2 May 2023 16:36:26 +0000 Subject: [PATCH] chore(letter): use proper caching for pdf generation via pandoc --- src/Handler/Qualification.hs | 2 +- src/Utils/Print.hs | 33 +++++++++--------- src/Utils/Print/Instances.hs | 66 ++++++++++++++++++++++++++++++++++++ 3 files changed, 84 insertions(+), 17 deletions(-) create mode 100644 src/Utils/Print/Instances.hs diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e245950e5..9147be219 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -410,7 +410,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay - getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 22b98c773..4e1f9954f 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -42,7 +42,7 @@ import Text.Hamlet import System.Exit import System.Process.Typed -- for calling pdftk for pdf encryption --- import Handler.Utils.Memcached +import Handler.Utils.Memcached import Handler.Utils.Users import Handler.Utils.DateTime import Handler.Utils.Mail @@ -50,7 +50,7 @@ import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Avs (updateReceivers) import Jobs.Handler.SendNotification.Utils --- import Utils.Print.Instances +import Utils.Print.Instances () import Utils.Print.Letters import Utils.Print.RenewQualification import Utils.Print.CourseCertificate @@ -110,29 +110,29 @@ 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 P.Pandoc) +mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either Text P.Pandoc) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } - -- doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template) - -- tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . P.runPure $ compileTemplate template) - doc <- ExceptT (pure . P.runPure $ P.readMarkdown readerOpts template) - tmpl <- ExceptT (pure . P.runPure $ compileTemplate template) + -- doc <- ExceptT (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) + -- tmpl <- ExceptT (pure . over _Left P.renderError . P.runPure $ compileTemplate template) + doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) + tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ compileTemplate template) let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } - ExceptT . pure . P.runPure $ do + ExceptT . pure . over _Left P.renderError . 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.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) +pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteString) pdfLaTeX lk doc = do - e_tmpl <- liftIO . P.runIO $ compileTemplate $ templateLatex lk - -- e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk) - actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do + -- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk + e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk) + actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) .liftIO . P.runIO $ do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } makePDF writerOpts $ appMeta setIsDeFromLang doc @@ -156,8 +156,8 @@ 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 - return $ over _Left P.renderError 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) @@ -185,8 +185,9 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent Right doc2 -> pure $ Right $ doc1 <> doc2 doc <- foldrM templateCombine (Right mempty) mdls - result <- actRight doc $ pdfLaTeX kind - return $ over _Left P.renderError result + -- result <- actRight doc $ pdfLaTeX kind + -- return $ over _Left P.renderError result + actRight doc $ pdfLaTeX kind | otherwise = return $ Left "renderLetters received empty set of letters" diff --git a/src/Utils/Print/Instances.hs b/src/Utils/Print/Instances.hs new file mode 100644 index 000000000..2d469021c --- /dev/null +++ b/src/Utils/Print/Instances.hs @@ -0,0 +1,66 @@ +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utils.Print.Instances where + +import Import.NoModel +-- import Import + +import qualified Text.DocTemplates.Internal as D +import qualified Text.DocLayout as D +import qualified Text.Pandoc as P + +----------------------------- +-- Pandoc Orphan Instances -- +----------------------------- + +-- deriving anyclass instance Generic IOException +-- deriving anyclass instance Binary IOException +-- deriving anyclass instance Binary HttpException +-- deriving anyclass instance Binary P.PandocError + + +-- required for memcaching compiled markdown and LaTeX templates +instance Binary P.RowHeadColumns +instance Binary P.RowSpan +instance Binary P.ColWidth +instance Binary P.ColSpan +instance Binary P.Alignment +instance Binary P.TableHead +instance Binary P.TableBody +instance Binary P.TableFoot +instance Binary P.MathType +instance Binary P.Cell +instance Binary P.Caption +instance Binary P.Citation +instance Binary P.CitationMode +instance Binary P.ListNumberStyle +instance Binary P.ListNumberDelim +instance Binary P.Format +instance Binary P.QuoteType +instance Binary P.Inline +instance Binary P.Row +instance Binary P.Block +instance Binary P.MetaValue +instance Binary P.Meta +instance Binary P.Pandoc + +-- -- and for memchaching a LaTeX template +deriving instance Binary D.Border +deriving instance Binary D.Alignment +deriving instance Binary D.Pipe +deriving instance Binary D.Variable +deriving instance (Binary a) => Binary (D.Doc a) +deriving instance (Binary a) => Binary (P.Template a) + +deriving instance NFData D.Border +deriving instance NFData D.Alignment +deriving instance NFData D.Pipe +deriving instance NFData D.Variable +deriving instance (NFData a) => NFData (D.Doc a) +deriving instance (NFData a) => NFData (P.Template a) + +-- TODO: sadly this is not yet enough. \ No newline at end of file