diff --git a/src/Handler/Admin/Apc.hs b/src/Handler/Admin/Apc.hs index 691ee2977..67efbdcf3 100644 --- a/src/Handler/Admin/Apc.hs +++ b/src/Handler/Admin/Apc.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 951be7675..ec041452e 100644 --- a/src/Utils.hs +++ b/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 (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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index d2901e8de..62761cbbd 100644 --- a/src/Utils/Print.hs +++ b/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.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 - --} \ No newline at end of file + 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