402 lines
16 KiB
Haskell
402 lines
16 KiB
Haskell
{-# 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 LmsUserId -> 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 printJobAcknowledged = Nothing
|
|
jobFullName = 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
|
|
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
|
|
}
|
|
-}
|
|
|
|
|
|
|
|
-----------------------------
|
|
-- 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
|
|
-}
|