fix(lpr): fix #96 by various minor improvements to PrintCenter

messages/uniworx/categories/print/de-de-formal.msg

@@ -4,6 +4,7 @@
 
 PJActAcknowledge: Druck und Versand bestätigen
 PJActReprint: Erneut drucken über APC
+PJActReprintIgnoreReroute: Drucken auch bei aktiver Mail-Umleitung erzwingen
 PrintJobName: Bezeichnung
 PrintJobFilename: Dateiname
 PrintJobId !ident-ok: Id 

messages/uniworx/categories/print/en-eu.msg

@@ -4,6 +4,7 @@
 
 PJActAcknowledge: Acknowledge printing and mailing
 PJActReprint: Print again via APC
+PJActReprintIgnoreReroute: Force printing to APC, even if mail-reroute-to option is active
 PrintJobName: Description
 PrintJobFilename: Filename
 PrintJobId: Id 

src/Handler/PrintCenter.hs

@@ -127,7 +127,7 @@ nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''PJTableAction id
 
 -- Not yet needed, since there is no additional data for now:
-data PJTableActionData  = PJActAcknowledgeData | PJActReprintData
+data PJTableActionData  = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
   deriving (Eq, Ord, Read, Show, Generic)
 
 type PJTableExpr = (                  E.SqlExpr (Entity PrintJob)
@@ -192,7 +192,7 @@ mkPJTable = do
     dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
     dbtProj = dbtProjId
     dbtColonnade = mconcat
-      [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
+      [ dbSelect (applying _2) id (return . view (resultPrintJob . _entityKey)) -- condition for dbSelectIf: (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
       , sortable (Just "created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated        -> t) ->      dateTimeCell t
       , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged   -> t) -> maybeDateTimeCell t
       , sortable (Just "filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
@@ -262,7 +262,8 @@ mkPJTable = do
           = let acts :: Map PJTableAction (AForm Handler PJTableActionData)
                 acts = mconcat
                   [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
-                  , singletonMap PJActReprint     $ pure PJActReprintData
+                  , singletonMap PJActReprint     $ PJActReprintData
+                      <$> aopt checkBoxField (fslI MsgPJActReprintIgnoreReroute) Nothing
                   ]
              in renderAForm FormStandard
                $  (, mempty) . First . Just
@@ -292,15 +293,23 @@ postPrintCenterR = do
       num <- runDB $ updateWhereCount  [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now]
       addMessageI Success $ MsgPrintJobAcknowledge num
       reloadKeepGetParams PrintCenterR
-    (PJActReprintData, Set.toList -> pjIds) -> do
+    (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do
-      let countOk = either (const $ Sum 0) (const $ Sum 1)
+      let countOk = either (const $ Sum 0) (const $ Sum 1)          
-      oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF
+      oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
       let nr_oks = getSum $ mconcat oks
           nr_tot = length pjIds
           mstat  = bool Warning Success $ nr_oks == nr_tot
       addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
       reloadKeepGetParams PrintCenterR
-
+  siteConf <- getYesod  
+  let lprConf = siteConf ^. _appLprConf
+      reroute = siteConf ^. _appMailRerouteTo
+      lprWgt  = [whamlet|
+          LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
+          <div>
+            $maybe _ <- reroute
+              Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!          
+        |]
   siteLayoutMsg MsgMenuApc $ do
     setTitleI MsgMenuApc
     $(widgetFile "print-center") --  i18nWidgetFile? Currently no text contained; displays just the table only

src/Utils/Print.hs

@@ -278,12 +278,12 @@ printLetter' pji pdf = do
       insert_ PrintJob {..}
       return $ Right (ok, printJobFilename)
 
-reprintPDF :: PrintJobId -> DB (Either Text Text)
+reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text)
-reprintPDF pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid
+reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid
   where 
     reprint :: PrintJob -> DB (Either Text Text)
     reprint pj@PrintJob{..} = do 
-      result <- lprPDF printJobFilename $ LBS.fromStrict printJobFile
+      result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
       whenIsRight result $ const $ do 
         now <- liftIO getCurrentTime        
         insert_ pj{ printJobAcknowledged  = Nothing
@@ -460,26 +460,29 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 
 -- | Internal only, use `printLetter` instead
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
-lprPDF (sanitizeCmdArg' -> jb) bs = do
+lprPDF = lprPDF' False
-    mbLprServerArg <- getLprServerArg
+
-    case mbLprServerArg of
+lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Bool -> FilePath -> LBS.ByteString -> m (Either Text Text)
-      Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
+lprPDF' ignoreReroute (sanitizeCmdArg' -> jb) bs = maybeM hdlFail hdlLpr getLprServerArg
-      Just lprServerArg -> do
+  where 
-        let pc = setStdin (byteStringInput bs) $
+    hdlFail = return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
-                  proc "lpr" $
+    
-                    jobname ++                                      -- -J jobname -- a name for job identification at printing site
+    hdlLpr lprServerArg = do
-                    [ lprServerArg                                  -- -P queue@hostname:port
+      let pc = setStdin (byteStringInput bs) $
-                    , "-"                                           -- read from stdin
+                proc "lpr" $
-                    ]
+                  jobname ++                                      -- -J jobname -- a name for job identification at printing site
-            jobname | null jb   = []
+                  [ lprServerArg                                  -- -P queue@hostname:port
-                    | otherwise = ["-J " <> jb]            
+                  , "-"                                           -- read from stdin
-        exit2either <$> readProcess' pc
+                  ]
-  where
+          jobname | null jb   = []
+                  | otherwise = ["-J " <> jb]            
+      exit2either <$> readProcess' pc
+    
     getLprServerArg = do
       rerouteMail <- getsYesod $ view _appMailRerouteTo
-      case rerouteMail of
+      case (ignoreReroute, rerouteMail) of
-        Just _  -> return Nothing
+        (False, Just _) -> return Nothing
-        Nothing -> do
+        _ -> do
           LprConf{..} <- getsYesod $ view _appLprConf
           return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
 

templates/print-center.hamlet

@@ -6,4 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    ^{pjTable}
+    ^{pjTable}
+
+<section>
+  ^{modal "APC Konfiguration" (Right lprWgt)}