fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(letter): letter generation in handler; debugging

Browse Source
This commit is contained in:
Steffen Jost 2022-07-08 19:02:00 +02:00
parent cd6e560b4b
commit 104794a210
6 changed files with 178 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Handler/Admin/Test.hs
View File

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

76
src/Handler/PrintCenter.hs
View File

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

8
src/Model/Types/Markup.hs
View File

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

20
src/Utils.hs
View File

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

75
src/Utils/Print.hs
View File

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

40
testdata/test_letters.hs vendored Normal file
View File

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