-- SPDX-FileCopyrightText: 2022 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Utils.Print ( pdfRenewal , sendLetter , encryptPDF , sanitizeCmdArg, validCmdArgument , templateDIN5008 , templateRenewal -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values , mkMeta, appMeta, applyMetas -- multiple values ) where -- import Import.NoModel import Data.Char (isSeparator) import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as Fold import qualified Data.ByteString.Lazy as LBS 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 System.Exit import System.Process.Typed -- for calling pdftk for pdf encryption import Handler.Utils.Users (abbrvName) -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? {- Recall: Funktionen außerhalb der Hanlder-Monade gehören in Utils-Module; ansonsten drohen zyklische Abhängikeiten, d.h. ggf. Funktionen in der HandlerFor-Monade nach Handler.Utils.Print verschieben! -} ------------------------- -- Hardcoded Templates -- ------------------------- templateRenewal :: Text templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") templateDIN5008 :: Text templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") ---------------------- -- 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 makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString -- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.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 . LBS.toStrict) _Meta :: Lens' P.Pandoc P.Meta _Meta = lens mget mput where mget (P.Pandoc m _) = m mput (P.Pandoc _ b) m = P.Pandoc m b toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue toMeta k = singletonMap k . P.toMetaValue mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue mbMeta = foldMap . toMeta -- | For convenience and to avoid importing Pandoc mkMeta :: [Map Text P.MetaValue] -> P.Meta mkMeta = P.Meta . mconcat -- | 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 -- appMeta f = _Meta %~ f -- lens version. Not sure this is better -- TODO: applyMetas is inconvenient since we cannot have an instance -- ToMetaValue a => ToMetaValue (Maybe a) -- so apply Metas -- For tests see module PandocSpec applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p applyMetas metas doc = Fold.foldr act doc metas where act (_, Nothing) acc = acc act (k, Just v ) acc = P.setMeta k v acc -- | Add meta to pandoc. Existing variables will be overwritten. -- For specification, see module PandocSpec addMeta :: P.Meta -> P.Pandoc -> P.Pandoc addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not! --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 , isDe t = P.setMeta isde True m | otherwise = P.deleteMeta isde m where isde = "is-de" defReaderOpts :: P.ReaderOptions defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True } defWriterOpts :: P.Template Text -> P.WriterOptions defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t } ------------------------- -- 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. -- Pandoc currently only allows interpolation within templates. -- 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 tmpl <- compileTemplate strictMarkupInput doc <- areader readerOpts strictMarkupInput let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc 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 reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text reTemplateLetter' meta md = do tmpl <- compileTemplate md doc <- P.readMarkdown readerOpts md let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc where readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } --pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString pdfDIN5008' meta md = do tmpl <- compileTemplate templateDIN5008 let readerOpts = def { P.readerExtensions = P.pandocExtensions } writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } doc <- P.readMarkdown readerOpts md makePDF writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc -- | creates a PDF using the din5008 template pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) pdfDIN5008 meta 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.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } doc <- P.readMarkdown readerOpts md makePDF writerOpts $ appMeta setIsDeFromLang $ addMeta meta 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 Text LBS.ByteString) pdfRenewal meta = do e_txt <- mdRenewal' meta --actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this result <- actRight e_txt $ pdfDIN5008 meta return $ over _Left P.renderError result -- | like pdfRenewal but without caching pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString pdfRenewal' meta = do doc <- reTemplateLetter' meta templateRenewal pdfDIN5008' meta doc --------------- -- PrintJobs -- --------------- sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse quali <- join <$> mapM get printJobQualification let nameRecipient = abbrvName <$> recipient nameSender = abbrvName <$> sender nameCourse = CI.original . courseShorthand <$> course nameQuali = CI.original . qualificationShorthand <$> quali let jobFullName = text2asciiAlphaNum $ T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) printJobFilename = T.unpack $ jobFullName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing lprPDF jobFullName pdf >>= \case Left err -> do return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows insert_ PrintJob {..} return $ Right (ok, printJobFilename) {- sendLetter' :: _ -> DB PureFile sendLetter' _ = do ... return $ File { fileTitle = printJobFilename , fileModified = printJobCreated , fileContent = Just $ yield printJobFile } -} {- Probably not needed:} data SomeUserTime where SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime data ProtoMeta = IsMeta P.MetaValue | IsTime SomeUserTime convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue convertProto _ (IsMeta v) = v convertProto f (IsTime t) = P.toMetaValue $ f t -} class MDLetter l where letterMeta :: l -> Languages -> DateTimeFormatter -> P.Meta getTemplate :: Proxy l -> Text -- l -> Text might actually be easier to handle? data LetterRenewQualification = LetterRenewQualification { lmsLogin :: LmsIdent , lmsPin :: Text , qualExpiry :: Day , qualDuration :: Maybe Int } deriving (Eq, Show) instance MDLetter LetterRenewQualification where getTemplate _ = templateRenewal letterMeta LetterRenewQualification{..} _langs DateTimeFormatter{..} = mkMeta [ toMeta "login" lmsIdent , toMeta "pin" lmsPin , toMeta "expiry" (format SelFormatDate qualExpiry) , mbMeta "validduration" (show <$> qualDuration) , toMeta "url-text" lmsUrl , toMeta "url" lmsUrlLogin ] where lmsUrl = "https://drive.fraport.de" lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin {- -- sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m (?) sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid forM receivers $ \Entity -} ----------------------------- -- Typed Process Utilities -- ----------------------------- -- | Converts Triple consisting of @ExitCode@, Success- and Failure-Value to Either Failue- or Success-Value. -- Returns @Right@ if the @ExitCode@ is @ExitsSuccess, entirely ignoring the Failure-Value, which might contain warning messages. -- To be used with 'System.Process.Typed.readProcess' exit2either :: (ExitCode, a, b) -> Either b a exit2either (ExitSuccess , ok, _) = Right ok -- warnings are ignored here! exit2either (ExitFailure _ , _, err) = Left err readProcess' :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Text, Text) readProcess' pc = do (ec, bs_err, bs_out) <- readProcess pc let st_err = decodeUtf8 $ LBS.toStrict bs_err st_out = decodeUtf8 $ LBS.toStrict bs_out return (ec, st_err, st_out) sanitizeCmdArg :: Text -> Text sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) -- | Returns Nothing if ok, otherwise the first mismatching character -- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk validCmdArgument :: Text -> Maybe Char validCmdArgument t = t `textDiff` sanitizeCmdArg t ----------- -- pdftk -- ----------- -- -- We use the external tool pdftk for PDF encryption like so -- > pdftk in.pdf output out.pdf user_pw tomatenmarmelade -- we can use stdin and std out like so -- > pdftk - output - user_pw tomatenmarmelade -- encryptPDF :: MonadIO m => Text -> LBS.ByteString -> m (Either Text LBS.ByteString) encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc where pw' = sanitizeCmdArg pw pc = setStdin (byteStringInput bs) $ proc "pdftk" [ "-" -- read from stdin , "output", "-" -- write to stdout , "user_pw", T.unpack pw' -- encrypt pdf content , "dont_ask" -- no interaction , "allow", "Printing" -- allow printing despite encryption ] -- Note that pdftk will issue a warning, which will be ignored: -- Warning: Using a password on the command line interface can be insecure. -- Use the keyword PROMPT to supply a password via standard input instead. --------- -- lpr -- --------- -- -- We use the external tool lpr in the variant supplied by busybox -- to print pdfs like so: -- > lpr -P fradrive@fravm017173.fra.fraport.de:515 -J printJobName - -- -- The cups version of lpr is instead used like so: -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - -- | Internal only, use `sendLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg let pc = setStdin (byteStringInput bs) $ proc "lpr" $ jobname ++ -- -J jobname -- a name for job identification at printing site [ lprServerArg -- -P queue@hostname:port , "-" -- read from stdin ] jobname | null jb = [] | otherwise = ["-J " <> jb'] jb' = T.unpack $ sanitizeCmdArg jb exit2either <$> readProcess' pc where getLprServerArg = do LprConf{..} <- getsYesod $ view _appLprConf return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort {- -- Variant without caching lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text) lprPDF' jb bs = do LprConf{..} <- getsYesod $ view _appLprConf let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort pc = setStdin (byteStringInput bs) $ proc "lpr" $ [ "-P " <> lprServer -- queue@hostname:port ] ++ jobname ++ -- a name for job identification at printing site [ "-" -- read from stdin ] jobname | null jb = [] | otherwise = ["-J " <> jb] exit2either <$> readProcess' pc -}