From 5e7b511eb2ab7af1b2a22aaa07d31d5be1af56b6 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Mon, 15 Aug 2022 14:07:16 +0200
Subject: [PATCH] chore(lpr): make lpr settings configurable via env or yml

---
 config/settings.yml |  5 +++++
 src/Settings.hs     | 16 ++++++++++++++++
 src/Utils/Print.hs  | 40 +++++++++++++++++++++++++++++-----------
 3 files changed, 50 insertions(+), 11 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 4cf018f7a..1da144da9 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -131,6 +131,11 @@ avs:
   user:    "_env:AVSUSER:fradrive"
   pass:    "_env:AVSPASS:"
 
+lpr:
+  host:    "_env:LPRHOST:fravm017173.fra.fraport.de"
+  port:    "_env:LPRPORT:515"
+  queue:   "_env:LPRQUEUE:fradrive"  
+
 smtp:
   host:    "_env:SMTPHOST:"
   port:    "_env:SMTPPORT:25"
diff --git a/src/Settings.hs b/src/Settings.hs
index 2ce4292b7..33c2f40ca 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -96,6 +96,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the LDAP-directory
     , appAvsConf                :: Maybe AvsConf
     -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
+    , appLprConf                :: LprConf
+    -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
     , appSmtpConf               :: Maybe SmtpConf
     -- ^ Configuration settings for accessing a SMTP Mailserver
     , appWidgetMemcachedConf    :: Maybe WidgetMemcachedConf
@@ -306,6 +308,12 @@ data AvsConf = AvsConf
   , avsPass :: ByteString
   } deriving (Show)
 
+data LprConf = LprConf
+  { lprHost :: String
+  , lprPort :: Int
+  , lprQueue:: String  
+  } deriving (Show)
+
 data SmtpConf = SmtpConf
   { smtpHost :: HaskellNet.HostName
   , smtpPort :: HaskellNet.PortNumber
@@ -480,6 +488,13 @@ instance FromJSON AvsConf where
     avsPass <- o .:? "pass" .!= ""
     return AvsConf{..}
 
+instance FromJSON LprConf where
+  parseJSON = withObject "LprConf" $ \o -> do
+    lprHost  <- o .: "host"
+    lprPort  <- o .: "port"
+    lprQueue <- o .: "queue"    
+    return LprConf{..}
+
 instance FromJSON SmtpConf where
   parseJSON = withObject "SmtpConf" $ \o -> do
     smtpHost <- o .:? "host" .!= ""
@@ -562,6 +577,7 @@ instance FromJSON AppSettings where
               Ldap.Plain host -> not $ null host
         appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
+        appLprConf                <- o .: "lpr"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
         let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
               [ not $ null connectHost
diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs
index eec40cbcb..6470441d6 100644
--- a/src/Utils/Print.hs
+++ b/src/Utils/Print.hs
@@ -320,14 +320,32 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 --  > lpr -P fradrive@fravm017173.fra.fraport.de -J printJobName -
 --
 
-lprPDF :: MonadIO m => String -> LBS.ByteString -> m (Either Text Text)
-lprPDF jb bs = over _Left  (decodeUtf8 . LBS.toStrict) .
-               over _Right (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
-  where
-    pc =  setStdin (byteStringInput bs) $
-          proc "lpr" $ [ "-P fradrive@fravm017173.fra.fraport.de:515"  -- queue@hostname:port TODO: turn this into a setting
-                       ] ++ jobname ++                                 -- a name for job identification at printing site
-                       [ "-"                                           -- read from stdin
-                       ]
-    jobname | null jb   = []
-            | otherwise = ["-J", jb]
+lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
+lprPDF' jb bs = do 
+  LprConf{..} <- getsYesod $ view _appLprConf
+  let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort
+      pc =  setStdin (byteStringInput bs) $
+            proc "lpr" $ [ "-P " <> lprServer                            -- queue@hostname:port
+                         ] ++ jobname ++                                 -- a name for job identification at printing site
+                         [ "-"                                           -- read from stdin
+                         ]
+      jobname | null jb   = []
+              | otherwise = ["-J " <> jb]
+  over _Left  (decodeUtf8 . LBS.toStrict) . over _Right (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
+
+lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
+lprPDF jb bs = do 
+    lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg 
+    let pc =  setStdin (byteStringInput bs) $
+              proc "lpr" $ jobname ++                                      -- -J jobname -- a name for job identification at printing site      
+                          [ lprServerArg                                  -- -P queue@hostname:port
+                          , "-"                                           -- read from stdin
+                          ]
+        jobname | null jb   = []
+                | otherwise = ["-J " <> jb]
+    over _Left  (decodeUtf8 . LBS.toStrict) . over _Right (decodeUtf8 . LBS.toStrict) . exit2either <$> readProcess pc
+  where 
+    getLprServerArg = do 
+      LprConf{..} <- getsYesod $ view _appLprConf
+      return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
+