From 104794a210cacc2fbf192973006f3485d7a34420 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 8 Jul 2022 19:02:00 +0200 Subject: [PATCH] chore(letter): letter generation in handler; debugging --- src/Handler/Admin/Test.hs | 8 ++-- src/Handler/PrintCenter.hs | 76 ++++++++++++++++++++++++-------------- src/Model/Types/Markup.hs | 8 ++++ src/Utils.hs | 20 ++++++++-- src/Utils/Print.hs | 75 ++++++++++++++++++++++++++++++------- testdata/test_letters.hs | 40 ++++++++++++++++++++ 6 files changed, 178 insertions(+), 49 deletions(-) create mode 100644 testdata/test_letters.hs diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index b0533c951..3563b430c 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -13,7 +13,7 @@ import Jobs import Data.Char (isDigit) import qualified Data.Text as Text -- import qualified Data.Text.IO as Text -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Map as Map @@ -303,7 +303,7 @@ getAdminTestPdfR = do P.setDate (P.text . tshow $ utctDay now) doc3 case content of Right (Right bs) -> do - liftIO $ L.writeFile "/tmp/generated.pdf" bs - sendByteStringAsFile "demoPDF.pdf" (L.toStrict bs) now - Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ L.toStrict $ "LaTeX compile error: \n" <> err + liftIO $ LBS.writeFile "/tmp/generated.pdf" bs + sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now + Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "LaTeX compile error: \n" <> err Left err -> sendResponseStatus internalServerError500 $ "Pandoc error: \n" <> P.renderError err diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 825090d52..3e28ab9a2 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -3,17 +3,19 @@ module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR + -- TODO: for testing only, remove exports + , mprToMeta ) where import Import import qualified Data.Text as T import qualified Data.Text.Lazy as LT --- import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy as LBS import qualified Text.Pandoc as P import qualified Text.Pandoc.Builder as P import qualified Control.Monad.State.Class as State --- import Utils.Print +import Utils.Print -- import Data.Aeson (encode) -- import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -33,29 +35,19 @@ data MetaPinRenewal = MetaPinRenewal } deriving (Eq, Ord, Show, Generic, Typeable) -formToMetaValues :: MetaPinRenewal -> P.Meta -formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat - [ toMeta "recipient" mppRecipient - , toMeta "address" (mppAddress & html2textlines) - , toMeta "login" mppLogin - , toMeta "pin" mppPin - , mbMeta "url" (mppURL <&> tshow) - , toMeta "date" (mppDate & tshow) -- TODO: render according to user preference - , toMeta "lang" mppLang - , mbMeta keyOpening mppOpening - , mbMeta keyClosing mppClosing - ] - where - deOrEn = if isDe mppLang then "de" else "en" - keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" - mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue - mbMeta = foldMap . toMeta - toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue - toMeta k = singletonMap k . P.toMetaValue - html2textlines :: StoredMarkup -> [Text] - html2textlines sm = T.lines . LT.toStrict $ markupInput sm - +-- TODO: just for testing, remove in production +instance Default MetaPinRenewal where + def = MetaPinRenewal + { mppRecipient = "Papa Schlumpf" + , mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text) + , mppLogin = "keiner123" + , mppPin = "898989" + , mppURL = Nothing + , mppDate = fromGregorian 2022 07 27 + , mppLang = "de-de" + , mppOpening = Just "Lieber Papa Schlumpfi," + , mppClosing = Nothing + } makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do @@ -76,6 +68,29 @@ validateMetaPinRenewal = do MetaPinRenewal{..} <- State.get guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang +mprToMeta :: MetaPinRenewal -> P.Meta +mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat + [ toMeta "recipient" mppRecipient + , toMeta "address" (mppAddress & html2textlines) + , toMeta "login" mppLogin + , toMeta "pin" mppPin + , mbMeta "url" (mppURL <&> tshow) + , toMeta "date" (mppDate & tshow) -- TODO: render according to user preference + , toMeta "lang" mppLang + , mbMeta keyOpening mppOpening + , mbMeta keyClosing mppClosing + ] + where + deOrEn = if isDe mppLang then "de" else "en" + keyOpening = deOrEn <> "-opening" + keyClosing = deOrEn <> "-closing" + mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue + mbMeta = foldMap . toMeta + toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue + toMeta k = singletonMap k . P.toMetaValue + html2textlines :: StoredMarkup -> [Text] + html2textlines sm = T.lines . LT.toStrict $ markupInput sm + getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR @@ -88,10 +103,17 @@ postPrintCenterR = do getPrintSendR, postPrintSendR:: Handler Html getPrintSendR = postPrintSendR -postPrintSendR = do +postPrintSendR = do ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing - let procFormSend MetaPinRenewal{..} = do + let procFormSend mpr@MetaPinRenewal{..} = do addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient + e_pdf <- pdfRenewal $ mprToMeta mpr + -- now <- liftIO getCurrentTime + case e_pdf of + Right bs -> do + liftIO $ LBS.writeFile "/tmp/generated.pdf" bs + addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" + Left err -> addMessage Error . toHtml $ P.renderError err -- TODO: continue here with acutal letter sending! return $ Just () mbPdfLink <- formResultMaybe sendResult procFormSend diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index bba69312b..d4df4a060 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -2,6 +2,7 @@ module Model.Types.Markup ( MarkupFormat(..) , StoredMarkup(..) , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup + , markdownToStoredMarkup , esqueletoMarkupOutput , I18nStoredMarkup , markupIsSmallish @@ -62,6 +63,13 @@ preEscapedToStoredMarkup (repack -> t) = StoredMarkup , markupInput = fromStrict t , markupOutput = preEscapedToMarkup t } +markdownToStoredMarkup :: Textual t => t -> StoredMarkup +markdownToStoredMarkup (repack -> t) = StoredMarkup + { markupInputFormat = MarkupMarkdown + , markupInput = t + , markupOutput = toMarkup t -- not sure here + } + esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html) esqueletoMarkupOutput sMarkup = E.maybe (E.val mempty) E.veryUnsafeCoerceSqlExprValue $ E.maybe (sMarkup E.#>>. "{}") E.just (sMarkup E.#>>. "{\"markup-output\"}") diff --git a/src/Utils.hs b/src/Utils.hs index ec041452e..d92f3f50f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -867,13 +867,13 @@ maybeRight :: Either a b -> Maybe b maybeRight (Right b) = Just b maybeRight _ = Nothing -whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m () +whenIsLeft :: Applicative f => Either a b -> (a -> f ()) -> f () whenIsLeft (Left x) f = f x -whenIsLeft (Right _) _ = return () +whenIsLeft (Right _) _ = pure () -whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m () +whenIsRight :: Applicative f => Either a b -> (b -> f ()) -> f () whenIsRight (Right x) f = f x -whenIsRight (Left _) _ = return () +whenIsRight (Left _) _ = pure () throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a throwLeft = either throwM return @@ -883,6 +883,18 @@ mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft = over _Left -} +actLeft :: Applicative f => Either a b -> (a -> f (Either c b)) -> f (Either c b) +actLeft (Left x) f = f x +actLeft (Right y) _ = pure $ Right y + +-- | like monadic bind for 'Either', but wrapped in another monad +-- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead +actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c) +actRight (Left x) _ = pure $ Left x +actRight (Right y) f = f y + + + --------------- -- Exception -- --------------- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index a07d64b5e..76d792e30 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -93,11 +93,13 @@ reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text reTemplateLetter meta StoredMarkup{..} = do tmpl <- compileTemplate strictMarkupInput -- TODO: write cacheHere Version using DB Key of StoredMarkup with Unique DB Argument instead of StoredMarkup - doc1 <- areader readerOpts strictMarkupInput - let writerOpts = def { P.writerTemplate = Just tmpl } + doc <- areader readerOpts strictMarkupInput + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl } P.writeMarkdown writerOpts + $ P.setMeta ("foooooo"::Text) ("baaaaaaar"::Text) -- TODO: just for debugging $ appMeta setIsDeFromLang - $ addMeta meta doc1 + $ addMeta meta doc where strictMarkupInput = toStrict markupInput readerOpts = def { P.readerExtensions = P.pandocExtensions @@ -110,23 +112,68 @@ reTemplateLetter meta StoredMarkup{..} = do MarkupPlaintext -> P.readMarkdown --pdfDIN5008 :: P.PandocMonad m => Text -> m L.ByteString -- for pandoc > 2.18 -pdfDIN5008 :: Text -> P.PandocIO L.ByteString -pdfDIN5008 md = do +pdfDIN5008' :: Text -> P.PandocIO L.ByteString +pdfDIN5008' md = do tmpl <- compileTemplate templateDIN5008 let readerOpts = def { P.readerExtensions = P.pandocExtensions } - writerOpts = def { P.writerTemplate = Just tmpl } + writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl } doc <- P.readMarkdown readerOpts md makePDF writerOpts doc - -pdfDIN5008' :: Text -> HandlerFor UniWorX (Either P.PandocError L.ByteString) -pdfDIN5008' md = do - etmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008) - case etmpl of - Left err -> return $ Left err - Right tmpl -> liftIO . P.runIO $ do +-- | creates a PDF using the din5008 template +pdfDIN5008 :: Text -> HandlerFor UniWorX (Either P.PandocError L.ByteString) +pdfDIN5008 md = do + e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008) + actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions } - writerOpts = def { P.writerTemplate = Just tmpl } + writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl } doc <- P.readMarkdown readerOpts md makePDF writerOpts doc + + +------------------------- +-- Specialized Letters -- +------------------------- + +-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result +mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) +mdRenewal' meta = do + let readerOpts = def { P.readerExtensions = P.pandocExtensions + , P.readerStripComments = True + } + e_doc <- $cachedHereBinary ("renewal-pandoc"::Text) (liftIO . P.runIO $ P.readMarkdown readerOpts templateRenewal) + e_tmpl <- $cachedHereBinary ("renewal-template"::Text) (liftIO . P.runIO $ compileTemplate templateRenewal) + case (e_doc, e_tmpl) of + (Left err, _) -> pure $ Left err + (_, Left err) -> pure $ Left err + (Right md_doc, Right md_tmpl) -> do + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just md_tmpl + } + liftIO . P.runIO $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang + $ addMeta meta md_doc + +-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result +mdRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) +mdRenewal meta = runExceptT $ do + let readerOpts = def { P.readerExtensions = P.pandocExtensions + , P.readerStripComments = True + } + doc <- ExceptT $ $cachedHereBinary ("renewal-pandoc"::Text) (pure . P.runPure $ P.readMarkdown readerOpts templateRenewal) + tmpl <- ExceptT $ $cachedHereBinary ("renewal-template"::Text) (pure . P.runPure $ compileTemplate templateRenewal) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl + } + ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang + $ addMeta meta doc + + +-- | combines 'mdRenewal' and 'pdfDIN5008' +pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError L.ByteString) +pdfRenewal meta = do + e_txt <- mdRenewal' meta + --actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this + actRight e_txt pdfDIN5008 \ No newline at end of file diff --git a/testdata/test_letters.hs b/testdata/test_letters.hs new file mode 100644 index 000000000..6fd248d80 --- /dev/null +++ b/testdata/test_letters.hs @@ -0,0 +1,40 @@ +-- usage: +-- > npm run build +-- > stack ghci -- testdata/test_letters.hs + +-- Also see: https://stackoverflow.com/questions/62006705/pandoc-output-in-markdown-how-to-add-the-metadata + +import Import +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as LBS + +import qualified Text.Pandoc as P +import qualified Text.Pandoc.PDF as P +import qualified Text.Pandoc.Builder as P + +import Model.Types.Markup +import Utils.Print +import Handler.PrintCenter + + +test :: IO T.Text +test = do + res <- P.runIO $ reTemplateLetter (Handler.PrintCenter.mprToMeta def) (markdownToStoredMarkup templateRenewal) + return $ case res of + Left err -> P.renderError err + Right t -> t + +test1 = appMeta setIsDeFromLang $ addMeta (mprToMeta def) mempty + +test2 = P.runIOorExplode $ do + let readerOpts = def { P.readerExtensions = P.pandocExtensions + , P.readerStripComments = True + , P.readerStandalone = True + } + P.readMarkdown readerOpts templateRenewal + +test3 = do + doc1 <- test2 + let doc2 = P.setMeta (T.pack "foooooo") (T.pack "baaaaaaar") $ appMeta setIsDeFromLang $ addMeta (mprToMeta def) doc1 + writerOpts = def { P.writerExtensions = P.enableExtension P.Ext_yaml_metadata_block P.pandocExtensions} + P.runIOorExplode $ P.writeMarkdown writerOpts doc2 \ No newline at end of file