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

chore(print): generalise pdf generation with din5008

Browse Source
This commit is contained in:
Steffen Jost 2022-07-06 14:55:24 +02:00
parent 0eb165da9b
commit 5fd28c0150
3 changed files with 98 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
src/Handler/Admin/Apc.hs
View File

@ -25,30 +25,12 @@ data MetaPinRenewal = MetaPinRenewal
, mppPin :: Text
, mppRecipient :: Text
, mppAddress :: [Text]
, mppLang :: Text
, mppIsDe :: Bool
, mppLang :: Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
formToMetaValues :: MetaPinRenewal -> P.Meta
formToMetaValues MetaPinRenewal{..} = P.Meta . mconcat $ catMaybes
[ toMeta "opening" <$> mppOpening
, toMeta "closing" <$> mppClosing
, toMeta "date" <$> mppDate
, toMeta "url" <$> mppURL
, toMeta "login" mppLogin & pure
, toMeta "pin" mppPin & pure
, toMeta "recipient" mppRecipient & pure
, toMeta "address" mppAddress & pure
, toMeta "lang" mppLang & pure
, toMeta "is-de" mppIsDe & pure
]
where
toMeta k = singletonMap k . P.toMetaValue
formToMetaValues2 :: MetaPinRenewal -> P.Meta
formToMetaValues2 MetaPinRenewal{..} = P.Meta $ mconcat
formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat
[ mbMeta "opening" mppOpening
, mbMeta "closing" mppClosing
, mbMeta "date" mppDate
@ -57,23 +39,26 @@ formToMetaValues2 MetaPinRenewal{..} = P.Meta $ mconcat
, toMeta "pin" mppPin
, toMeta "recipient" mppRecipient
, toMeta "address" mppAddress
, toMeta "lang" mppLang
, toMeta "is-de" mppIsDe
, toMeta "lang" mppLang
]
where
mbMeta _ Nothing = mempty
mbMeta k (Just x) = toMeta k x
mbMeta = foldMap . toMeta
toMeta k = singletonMap k . P.toMetaValue
{-
makePrintForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
makePrintForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html ->
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html ->
flip (renderAForm FormStandard) html $ MetaPinRenewal
<$> aopt textField (fslI MsgMppOpening) (mppOpening <$> tmpl)
<*> aopt textField (fslI MsgMppClosing) (mppClosing <$> tmpl)
<*> aopt textField (fslI MsgMppDate) (mppDate <$> tmpl)
<*> aopt textField (fslI MsgMppURL) (mppURL <$> tmpl)
<*> aopt textField (fslI MsgMppnNo) (mppRecipient <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq boolField (fslI MsgMppIsDe) (mppIsDe <$> tmpl)
validateMetaPinReneqal :: FormValidator MetaPinRenewal Handler ()
validateMetaPinReneqal = do

6
src/Utils.hs
View File

@ -664,12 +664,10 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList
maybeMap :: IsMap p => ContainerKey p -> Maybe (MapValue p) -> p
maybeMap _ Nothing = mempty
maybeMap k (Just v) = singletonMap k v
maybeMap k = foldMap (singletonMap k)
maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p
maybeMapWith _ _ Nothing = mempty
maybeMapWith f k (Just v) = singletonMap k $ f v
maybeMapWith f k = foldMap $ singletonMap k . f
-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons)
countMapElems :: (Ord v) => Map k v -> Map v Int

120
src/Utils/Print.hs
View File

@ -1,19 +1,25 @@
module Utils.Print where
import Import.NoModel
import qualified Data.Foldable as Fold
-- import qualified Data.Foldable as Fold
-- hiding (foldr) import Data.Foldable (foldr)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as L
import Control.Monad.Except
import Import hiding (embedFile)
import Data.FileEmbed (embedFile)
import qualified Text.Pandoc as P
-- import qualified Text.Pandoc.PDF as P
import qualified Text.Pandoc.Builder as P
import qualified Text.Pandoc as P
import qualified Text.Pandoc.PDF as P
import qualified Text.Pandoc.Builder as P
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
-------------------------
-- Hardcoded Templates --
-------------------------
templateRenewal :: Text
templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
@ -21,17 +27,60 @@ templateDIN5008 :: Text
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
-- setMeta :: (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
-- foldr :: forall b. (Element mono0 -> b -> b) -> b -> mono0 -> b
----------------------
-- Pandoc Functions --
----------------------
-- Either I don't understand how pandoc works or
-- I don't understand why these are not included
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
compileTemplate tmpl = do
let partialPath = "" -- no partials used, see Text.DocTemplates
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
liftEither $ str2pandocError mbTemplate
where
str2pandocError = over _Left $ P.PandocTemplateError . pack
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO L.ByteString
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m L.ByteString -- only pandoc >= 2.18
makePDF wopts doc = do
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
liftEither $ bs2pandocError mbPdf
where
texopts = []
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . L.toStrict)
-- | Modify the Meta-Block of Pandoc
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
-- applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
-- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
-- | Add meta to pandoc. Existing variables will be overwritten.
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
addMeta m p = meta <> p
where meta = P.Pandoc m mempty
addMeta m = appMeta (m <>)
--addMeta m p = meta <> p
-- where meta = P.Pandoc m mempty
-- | Pandoc conditionals only test if a variable is set or isn't set.
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
-- and will be unset otherwise
setIsDeFromLang :: P.Meta -> P.Meta
setIsDeFromLang m
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
, T.isPrefixOf "de" t
= P.setMeta isde True m
| otherwise = P.deleteMeta isde m
where
isde = "is-de"
-------------------------
-- Readers and writers --
-------------------------
-- | Apply StoredMarkup as a template to itself and return the resulting Markup
-- This is a hack to allow variable interpolation within a document.
@ -39,29 +88,28 @@ addMeta m p = meta <> p
-- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates
reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text
reTemplateLetter meta StoredMarkup{..} = do
let strictMarkupInput = toStrict markupInput
partialPath = "" -- no partials used, see Text.DocTemplates
mdTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath strictMarkupInput
case mdTemplate of
(Left err) -> throwError . P.PandocTemplateError $ pack err
(Right templ) -> do
let readeropts = def { P.readerExtensions = P.pandocExtensions }
writeropts = def { P.writerTemplate = Just templ }
-- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc
areader = case markupInputFormat of
MarkupHtml -> P.readHtml
MarkupMarkdown -> P.readMarkdown
MarkupPlaintext -> P.readMarkdown
doc1 <- areader readeropts strictMarkupInput
P.writeMarkdown writeropts $ addMeta meta doc1 -- should we apply metas here?
{-
renewalLetter :: (Foldable t, ToMetaValue b, PandocMonad m) => t (Text, b) -> PandocMonad m -> Text
renewalLetter
pdfDIN5008 :: MetaPinRenewal -> IO (Either ByteString ByteString)
pdfDIN5008
-}
tmpl <- compileTemplate strictMarkupInput
doc1 <- areader readerOpts strictMarkupInput
let writerOpts = def { P.writerTemplate = Just tmpl }
P.writeMarkdown writerOpts
$ appMeta setIsDeFromLang
$ addMeta meta doc1
where
strictMarkupInput = toStrict markupInput
readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True
}
-- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc
areader = case markupInputFormat of
MarkupHtml -> P.readHtml
MarkupMarkdown -> P.readMarkdown
MarkupPlaintext -> P.readMarkdown
--pdfDIN5008 :: P.PandocMonad m => Text -> m L.ByteString
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 }
doc <- P.readMarkdown readerOpts md
makePDF writerOpts doc