From bdfb38d8dcb6601b9ed829495e1d3f52d4a2869a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Sep 2022 17:05:10 +0200 Subject: [PATCH] pandoc: restrict exports of print modul to avoid rogue print jobs --- src/Handler/PrintCenter.hs | 2 +- .../Handler/SendNotification/Qualification.hs | 13 +++--- src/Utils/Print.hs | 44 +++++++++++++------ test/PandocSpec.hs | 26 ++++++++--- 4 files changed, 59 insertions(+), 26 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 87be13ffa..2768ff791 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -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)) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index f0b6f567d..eb4dc92b6 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index faea7a2aa..35dc3b21e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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 diff --git a/test/PandocSpec.hs b/test/PandocSpec.hs index abccb5c38..135f702ea 100644 --- a/test/PandocSpec.hs +++ b/test/PandocSpec.hs @@ -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