chore(letter): letter generation in handler; debugging

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
+          liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
-          sendByteStringAsFile "demoPDF.pdf" (L.toStrict bs) now
+          sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now
-        Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ L.toStrict $ "LaTeX compile error: \n" <> err
+        Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "LaTeX compile error: \n" <> err
         Left        err  -> sendResponseStatus internalServerError500 $ "Pandoc error: \n" <> P.renderError err

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,8 +35,41 @@ data MetaPinRenewal = MetaPinRenewal
       }
   deriving (Eq, Ord, Show, Generic, Typeable)
 
-formToMetaValues :: MetaPinRenewal -> P.Meta 
+-- TODO: just for testing, remove in production
-formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat 
+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
+  now_day <- utctDay <$> liftIO getCurrentTime
+  flip (renderAForm FormStandard) html $ MetaPinRenewal
+    <$> areq textField        (fslI MsgMppRecipient)         (mppRecipient <$> tmpl)
+    <*> areq htmlField        (fslI MsgMppAddress)           (mppAddress   <$> tmpl)
+    <*> areq textField        (fslI MsgMppLogin)             (mppLogin     <$> tmpl)
+    <*> areq textField        (fslI MsgMppPin)               (mppPin       <$> tmpl)
+    <*> aopt  urlField        (fslI MsgMppURL)               (mppURL       <$> tmpl)
+    <*> areq  dayField        (fslI MsgMppDate)             ((mppDate      <$> tmpl) <|> Just now_day)
+    <*> areq (langField True) (fslI MsgMppLang)             ((mppLang      <$> tmpl) <|> Just "de-de")
+    <*> aopt textField        (fslI MsgMppOpening)           (mppOpening   <$> tmpl)
+    <*> aopt textField        (fslI MsgMppClosing)           (mppClosing   <$> tmpl)
+
+validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
+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    
@@ -57,26 +92,6 @@ formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat
     html2textlines sm = T.lines . LT.toStrict $ markupInput sm
 
 
-makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
-makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
-  now_day <- utctDay <$> liftIO getCurrentTime
-  flip (renderAForm FormStandard) html $ MetaPinRenewal
-    <$> areq textField        (fslI MsgMppRecipient)         (mppRecipient <$> tmpl)
-    <*> areq htmlField        (fslI MsgMppAddress)           (mppAddress   <$> tmpl)
-    <*> areq textField        (fslI MsgMppLogin)             (mppLogin     <$> tmpl)
-    <*> areq textField        (fslI MsgMppPin)               (mppPin       <$> tmpl)
-    <*> aopt  urlField        (fslI MsgMppURL)               (mppURL       <$> tmpl)
-    <*> areq  dayField        (fslI MsgMppDate)             ((mppDate      <$> tmpl) <|> Just now_day)
-    <*> areq (langField True) (fslI MsgMppLang)             ((mppLang      <$> tmpl) <|> Just "de-de")
-    <*> aopt textField        (fslI MsgMppOpening)           (mppOpening   <$> tmpl)
-    <*> aopt textField        (fslI MsgMppClosing)           (mppClosing   <$> tmpl)
-
-validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
-validateMetaPinRenewal = do 
-  MetaPinRenewal{..} <- State.get
-  guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
-
-
 getPrintCenterR,  postPrintCenterR :: Handler Html
 getPrintCenterR = postPrintCenterR
 postPrintCenterR = do 
@@ -90,8 +105,15 @@ getPrintSendR, postPrintSendR:: Handler Html
 getPrintSendR = postPrintSendR  
 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 

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\"}")

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 --
 ---------------

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
+    doc <- areader readerOpts strictMarkupInput
-    let writerOpts = def { P.writerTemplate = Just tmpl }
+    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' :: Text -> P.PandocIO L.ByteString
-pdfDIN5008 md = do
+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
 
-
+-- | creates a PDF using the din5008 template
-pdfDIN5008' :: Text -> HandlerFor UniWorX (Either P.PandocError L.ByteString)
+pdfDIN5008 :: Text -> HandlerFor UniWorX (Either P.PandocError L.ByteString)
-pdfDIN5008' md = do
+pdfDIN5008 md = do
-  etmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
+  e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
-  case etmpl of
+  actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
-    Left  err  -> return $ Left err
-    Right 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 

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