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

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))

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
+        runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case        
-        -- lprPDF printJobName pdf >>= \case
           Left err -> do
             let msg = "Notify " <> tshow jRecipient <> "  PDF printing to send letter failed with error: " <> err
             $logErrorS "LMS" msg

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 :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
-applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
+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
+          proc "pdftk"  [ "-"                     -- read from stdin
-                        , "output", "-"       -- write to stdout
+                        , "output", "-"           -- write to stdout
-                        , "user_pw", pw       -- encrypt pdf content
+                        , "user_pw", T.unpack pw  -- encrypt pdf content
-                        , "dont_ask"          -- no interaction
+                        , "dont_ask"              -- no interaction
-                        , "allow", "Printing" -- allow printing despite encryption
+                        , "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 -
 
-
+-- | Internal only, use `sendLetter` instead
--- 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
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
 lprPDF jb bs = do 
     lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg 

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 (fmap (second Just) x4)
-                      $ applyMetas x5
+                      $ 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
+      (ml, abMetaOriginal, blocks) <- generate arbitrary
-      let
+      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