fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

pandoc: restrict exports of print modul to avoid rogue print jobs

Browse Source
This commit is contained in:
Steffen Jost 2022-09-02 17:05:10 +02:00
parent 59fe2819e9
commit bdfb38d8dc
4 changed files with 59 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/PrintCenter.hs
View File

@ -83,7 +83,7 @@ validateMetaPinRenewal = do
mprToMeta :: MetaPinRenewal -> P.Meta
mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
mprToMeta MetaPinRenewal{..} = mkMeta
-- formatTimeUser SelFormatDate mppDate mppRecipient
[ toMeta "recipient" mppRecipient
, toMeta "address" (mppRecipient : (mppAddress & html2textlines))

13
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -14,6 +14,8 @@ import Jobs.Handler.SendNotification.Utils
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
-- import Handler.Info (FAQItem(..))
import qualified Data.CaseInsensitive as CI
import Text.Hamlet
@ -49,7 +51,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
<*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
let entRecipient = Entity jRecipient recipient
qname = CI.original qualificationName
-- content = $(i18nWidgetFile "qualification/renewal")
$logDebugS "LMS" $ "Notify " <> tshow jRecipient <> " for renewal of qualification " <> qname
now <- liftIO getCurrentTime
@ -69,7 +71,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err
$logErrorS "LMS" msg
error $ unpack msg
Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do
Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do
-- userPrefersEmail is still true if both userEmail and userPostAddress are null
when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow jRecipient <> " failed: no email nor address for user known!")
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationRenewal qname
@ -78,7 +82,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
-- let msgrenewal = $(i18nHamletFile "qualification/renewal") -- :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
-- addHtmlMarkdownAlternatives' msgrenewal
encryptPDF "tomatenmarmelade" pdf >>= \case -- TODO: replace with user password!
encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO
Left err -> do
let msg = "Notify " <> tshow jRecipient <> " PDF encryption failed with error: " <> err
$logErrorS "LMS" msg
@ -94,8 +98,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
Right pdf | otherwise -> do
let printJobName = mempty --TODO
printSender = Nothing --TODO
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case
-- lprPDF printJobName pdf >>= \case
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case
Left err -> do
let msg = "Notify " <> tshow jRecipient <> " PDF printing to send letter failed with error: " <> err
$logErrorS "LMS" msg

44
src/Utils/Print.hs
View File

@ -1,4 +1,16 @@
module Utils.Print where
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print
( pdfRenewal
, sendLetter
, encryptPDF
, templateDIN5008
, templateRenewal
-- , compileTemplate, makePDF
, _Meta, addMeta
, toMeta, mbMeta -- single values
, mkMeta, appMeta, applyMetas -- multiple values
) where
-- import Import.NoModel
import qualified Data.Foldable as Fold
@ -82,9 +94,18 @@ 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, a) -> p -> p
applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
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
@ -318,15 +339,15 @@ readProcess' pc = do
-- > pdftk - output - user_pw tomatenmarmelade
--
encryptPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text LBS.ByteString)
encryptPDF :: MonadIO m => Text -> LBS.ByteString -> m (Either Text LBS.ByteString)
encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
where
pc = setStdin (byteStringInput bs) $
proc "pdftk" [ "-" -- read from stdin
, "output", "-" -- write to stdout
, "user_pw", pw -- encrypt pdf content
, "dont_ask" -- no interaction
, "allow", "Printing" -- allow printing despite encryption
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.
@ -344,10 +365,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
-- The cups version of lpr is instead used like so:
-- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName -
-- TODO: consider hiding this function within the export, as it does not create an entry in the printJob table in the DB
-- | Internal, use `sendLetter` instead
-- | Internal only, use `sendLetter` instead
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
lprPDF jb bs = do
lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg

26
test/PandocSpec.hs
View File

@ -23,13 +23,13 @@ instance Arbitrary ArbitraryMeta where
(x2 :: [Inlines]) <- filter (not . Fold.null) <$> arbitrary
(x3 :: Inlines) <- arbitrary
(x4 :: [(Text, Text)]) <- filter (not . T.null . fst) <$> arbitrary
(x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary
(x5 :: [(Text, Bool)]) <- filter (not . T.null . fst) <$> arbitrary
return $ ArbitraryMeta
$ setMeta "title" x1
$ setMeta "author" x2
$ setMeta "date" x3
$ applyMetas x4
$ applyMetas x5
$ applyMetas (fmap (second Just) x4)
$ applyMetas (fmap (second Just) x5)
nullMeta
@ -43,16 +43,28 @@ instance Arbitrary ArbitraryMeta where
spec :: Spec
spec = do
let mlist = Map.toList . unMeta
let mlist = Map.toAscList . unMeta
describe "applyMetas" $ do
it "should actually set values" $ do
(ml, pd) <- generate arbitrary
let
(ml, abMetaOriginal, blocks) <- generate arbitrary
let
metaOriginal = unArbitraryMeta abMetaOriginal
pd = Pandoc metaOriginal blocks
mlKeys = Set.fromList $ fst <$> ml
(Pandoc newMeta _) = applyMetas (fmap MetaString <$> ml) pd
(Pandoc newMeta _) = applyMetas (fmap (Just . MetaString) <$> ml) pd
ml' = [(k,t) | (k, MetaString t) <- mlist newMeta, Set.member k mlKeys]
ml `shouldMatchList` ml'
it "should preserve untouched settings" $ do
(ml, abMetaOriginal, blocks) <- generate arbitrary
let
metaOriginal = unArbitraryMeta abMetaOriginal
pd = Pandoc metaOriginal blocks
nullKeys = Set.fromList [k | (k, Nothing) <- ml]
(Pandoc newMeta _) = applyMetas (fmap (fmap MetaString) <$> ml) pd
oldm = [(k,t) | (k, t) <- mlist metaOriginal , Set.member k nullKeys]
newm = [(k,t) | (k, t) <- mlist newMeta , Set.member k nullKeys]
oldm `shouldMatchList` newm
describe "addMeta" $ do
it "should possibly overwrite existing settings" $ do