chore(print): generalise pdf generation with din5008

src/Handler/Admin/Apc.hs

@@ -25,30 +25,12 @@ data MetaPinRenewal = MetaPinRenewal
       , mppPin       :: Text
       , mppRecipient :: Text
       , mppAddress   :: [Text]
-      , mppLang      :: Text 
+      , mppLang      :: Text       
-      , mppIsDe      :: Bool
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 formToMetaValues :: MetaPinRenewal -> P.Meta 
-formToMetaValues MetaPinRenewal{..} = P.Meta . mconcat $ catMaybes
+formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat 
-  [ 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 
   [ 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 "lang"       mppLang       
-  , toMeta "is-de"      mppIsDe     
   ]
   where     
-    mbMeta _ Nothing  = mempty
+    mbMeta   = foldMap . toMeta
-    mbMeta k (Just x) = toMeta k x
     toMeta k = singletonMap k . P.toMetaValue
 
 {-
-makePrintForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
+makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
-makePrintForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> 
+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 

src/Utils.hs

@@ -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 = foldMap (singletonMap k)
-maybeMap k (Just v) = singletonMap k v
 
 maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p
-maybeMapWith _ _ Nothing  = mempty
+maybeMapWith f k = foldMap $ singletonMap k . f 
-maybeMapWith f k (Just v) = singletonMap k $ f v
 
 -- | 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

src/Utils/Print.hs

@@ -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         as P
--- import qualified Text.Pandoc.PDF     as P
+import qualified Text.Pandoc.PDF     as P
-import qualified Text.Pandoc.Builder  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 
+makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO L.ByteString
-applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
+-- 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
+addMeta m = appMeta (m <>)
-  where meta = P.Pandoc m mempty
+--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
+    tmpl <- compileTemplate    strictMarkupInput        
-      partialPath = "" -- no partials used, see Text.DocTemplates
+    doc1 <- areader readerOpts strictMarkupInput      
-  mdTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath strictMarkupInput
+    let writerOpts = def { P.writerTemplate = Just tmpl }
-  case mdTemplate of 
+    P.writeMarkdown writerOpts 
-    (Left err) -> throwError . P.PandocTemplateError $ pack err 
+      $ appMeta setIsDeFromLang
-    (Right templ) -> do
+      $ addMeta meta doc1 
-      let readeropts = def { P.readerExtensions = P.pandocExtensions }
+  where 
-          writeropts = def { P.writerTemplate = Just templ }
+    strictMarkupInput = toStrict markupInput
-          -- reader :: (P.PandocMonad m, P.ToSources a)	 => P.ReaderOptions	-> a	-> m P.Pandoc	 
+    readerOpts = def { P.readerExtensions    = P.pandocExtensions 
-          areader = case markupInputFormat of 
+                     , P.readerStripComments = True
-            MarkupHtml      -> P.readHtml
+                     }
-            MarkupMarkdown  -> P.readMarkdown
+    -- reader :: (P.PandocMonad m, P.ToSources a)	 => P.ReaderOptions	-> a	-> m P.Pandoc	 
-            MarkupPlaintext -> P.readMarkdown
+    areader = case markupInputFormat of 
-      doc1 <- areader readeropts strictMarkupInput      
+      MarkupHtml      -> P.readHtml
-      P.writeMarkdown writeropts $ addMeta meta doc1 -- should we apply metas here?
+      MarkupMarkdown  -> P.readMarkdown
-      
+      MarkupPlaintext -> P.readMarkdown
-
+  
-{-
+--pdfDIN5008 :: P.PandocMonad m => Text -> m L.ByteString
-
+pdfDIN5008 :: Text -> P.PandocIO L.ByteString
-renewalLetter :: (Foldable t, ToMetaValue b, PandocMonad m) => t (Text, b) -> PandocMonad m -> Text 
+pdfDIN5008 md = do
-renewalLetter 
+  tmpl <- compileTemplate templateDIN5008
-
+  let readerOpts  = def { P.readerExtensions = P.pandocExtensions }
-pdfDIN5008 :: MetaPinRenewal -> IO (Either ByteString ByteString)
+      writerOpts  = def { P.writerTemplate   = Just tmpl }
-pdfDIN5008 
+  doc <- P.readMarkdown readerOpts md 
-
+  makePDF writerOpts doc
--}