258 lines
9.3 KiB
Haskell
258 lines
9.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
|
|
|
module Utils.Print.Letters where
|
|
|
|
-- import Import.NoModel
|
|
import Import hiding (embedFile)
|
|
import Data.FileEmbed (embedFile)
|
|
import Data.Char as Char
|
|
import qualified Data.Text as Text
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Foldable as Fold
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import Control.Monad.Except
|
|
|
|
import qualified Text.Pandoc as P
|
|
import qualified Text.Pandoc.PDF as P
|
|
import qualified Text.Pandoc.Builder as P
|
|
|
|
import Text.Hamlet
|
|
|
|
-- import System.Exit
|
|
-- import System.Process.Typed -- for calling pdftk for pdf encryption
|
|
|
|
-- import Handler.Utils.Users
|
|
import Handler.Utils.DateTime
|
|
-- import Handler.Utils.Mail
|
|
-- import Handler.Utils.Widgets (nameHtml, nameHtml')
|
|
-- import Handler.Utils.Avs (updateReceivers)
|
|
-- import Jobs.Handler.SendNotification.Utils
|
|
|
|
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
|
|
|
|
|
|
-- instance P.ToMetaValue (CI Text) where
|
|
-- toMetaValue = P.MetaString . CI.original
|
|
|
|
----------------------
|
|
-- 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 (k, Just v) acc | notNull k = P.setMeta k v acc
|
|
act _ acc = 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 }
|
|
|
|
|
|
|
|
-------------------------
|
|
-- Hardcoded Templates --
|
|
-------------------------
|
|
|
|
|
|
data LetterKind = Din5008 -- scrlttr2: Standard postal letter with address field, expects peprinted FraportLogo
|
|
| PinLetter -- Like Din5008, but for special paper with a protected pin field
|
|
| Plain -- scrartcl: Empty, expects empty paper with no preprints
|
|
| PlainLogo -- Like plain, but expects to be printed on paper with Logo
|
|
-- | Logo -- Like plain, but prints Fraport Logo in the upper right corner
|
|
deriving (Eq, Show)
|
|
|
|
templateLatex :: LetterKind -> Text
|
|
templateLatex =
|
|
let
|
|
tDin5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
|
|
tPinLetter = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin.latex")
|
|
tPlain = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/plain_article.latex")
|
|
in \case
|
|
PinLetter -> tPinLetter
|
|
Din5008 -> tDin5008
|
|
PlainLogo -> tPlain
|
|
Plain -> tPlain
|
|
|
|
paperKind :: LetterKind -> Text -- Muss genau 5 Zeichen haben!
|
|
paperKind PinLetter = "a4pin" -- Pin-Brief
|
|
paperKind Plain = "a4wht" -- Ohne Logo
|
|
paperKind Din5008 = "a4log" -- Mit Logo
|
|
paperKind PlainLogo = "a4log"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------
|
|
-- PrintJobs --
|
|
---------------
|
|
|
|
apcIdentSeparator :: Text
|
|
apcIdentSeparator = Text.take 3 "___" -- must always have length 3
|
|
|
|
data PrintJobIdentification = PrintJobIdentification
|
|
{ pjiName :: Text
|
|
, pjiApcAcknowledge :: Text
|
|
, pjiRecipient :: Maybe UserId
|
|
, pjiSender :: Maybe UserId
|
|
, pjiCourse :: Maybe CourseId
|
|
, pjiQualification :: Maybe QualificationId
|
|
, pjiLmsUser :: Maybe LmsIdent
|
|
, pjiFileName :: Text -- suggested filename, without suffix ".pdf"
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
-- | create an identifier for printing with apc; which must always be place with the same length; exept for the last part which may be of variable length
|
|
-- this is printed in white on white at the exact same position on the page
|
|
-- Note: that all letters to the same UUID within 24h are collated in one envelope
|
|
-- Example: 9ad8de3f-0a7e-ede5-bd8b-6d0ed85c1049-f___a4pin___230322-10___lms-stuvwxyz
|
|
mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> Text -> Text
|
|
mkApcIdent uuid envelope lk tnow apcAck = Text.filter apcAcceptedChars $ Text.intercalate apcIdentSeparator
|
|
[ ensureLength 38 $ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope)
|
|
, ensureLength 5 $ paperKind lk
|
|
, ensureLength 9 tnow
|
|
, apcAck -- length may be arbitrary, thus far was always 12
|
|
]
|
|
where
|
|
ensureLength :: Int -> Text -> Text
|
|
ensureLength n = Text.take n . Text.justifyLeft n 'x'
|
|
|
|
-- | Character allowed to be included in the APC identifier string printed in white in the header of all printed letters, must not contain ',' nor ';'
|
|
apcAcceptedChars :: Char -> Bool
|
|
apcAcceptedChars '-' = True
|
|
apcAcceptedChars '_' = True
|
|
apcAcceptedChars c = isAlphaNum c
|
|
|
|
|
|
|
|
------------------
|
|
-- Letter Class --
|
|
------------------
|
|
|
|
{- 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
|
|
-}
|
|
|
|
data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling
|
|
deriving (Eq, Show)
|
|
|
|
class MDLetter l where
|
|
letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta -- formatter/lang for individual receiver, set Meta "lang" for individually translated letters
|
|
-- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetter for each receiver
|
|
getPJId :: l -> PrintJobIdentification
|
|
getLetterEnvelope :: l -> Char
|
|
getLetterKind :: l -> LetterKind
|
|
getTemplate :: l -> Text
|
|
encryptPDFfor :: l -> EncryptPDFfor
|
|
|
|
letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
|
|
letterApcIdent l uuid now = do
|
|
-- now <- liftIO getCurrentTime
|
|
tnow <- formatTime' "%y%m%d-%H" now
|
|
return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind l) tnow (pjiApcAcknowledge $ getPJId l)
|
|
|
|
letterFileName :: (MDLetter l) => l -> FilePath
|
|
letterFileName = Text.unpack . (<> ".pdf") . text2asciiAlphaNum . pjiFileName . getPJId
|
|
|
|
addApcIdent :: Text -> P.Meta
|
|
addApcIdent = P.Meta . toMeta "apc-ident"
|
|
|
|
getApcIdent :: P.Meta -> Maybe Text
|
|
getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t
|
|
getApcIdent _ = Nothing
|
|
|
|
|
|
----------------
|
|
-- Mail Class --
|
|
----------------
|
|
|
|
-- this is for letters that may alternatively be sent as attachments to emails
|
|
|
|
class MDMail l where --
|
|
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
|
|
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
|