diff --git a/models/users.model b/models/users.model index fe2560974..733247d1f 100644 --- a/models/users.model +++ b/models/users.model @@ -15,7 +15,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address -- TODO: make this nullable + email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 9c5b407ab..a4634cc50 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -45,7 +45,7 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton data MetaPinRenewal = MetaPinRenewal - { mppRecipient :: Text + { mppExaminee :: Text , mppAddress :: StoredMarkup , mppLogin :: Text , mppPin :: Text @@ -60,7 +60,7 @@ data MetaPinRenewal = MetaPinRenewal -- TODO: just for testing, remove in production instance Default MetaPinRenewal where def = MetaPinRenewal - { mppRecipient = "Papa Schlumpf" + { mppExaminee = "Papa Schlumpf" , mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text) , mppLogin = "keiner123" , mppPin = "89998a" @@ -75,7 +75,7 @@ makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ MetaPinRenewal - <$> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl) + <$> areq textField (fslI MsgMppRecipient) (mppExaminee <$> tmpl) <*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl) <*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl) <*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl) @@ -93,9 +93,9 @@ validateMetaPinRenewal = do mprToMeta :: MetaPinRenewal -> P.Meta mprToMeta MetaPinRenewal{..} = mkMeta - -- formatTimeUser SelFormatDate mppDate mppRecipient - [ toMeta "recipient" mppRecipient - , toMeta "address" (mppRecipient : (mppAddress & html2textlines)) + -- formatTimeUser SelFormatDate mppDate mppExaminee + [ toMeta "examinee" mppExaminee + , toMeta "address" (mppExaminee : (mppAddress & html2textlines)) , toMeta "login" mppLogin , toMeta "pin" mppPin , mbMeta "url" (mppURL <&> tshow) @@ -112,7 +112,7 @@ mprToMeta MetaPinRenewal{..} = mkMeta mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta mprToMetaUser entUser@Entity{entityVal = u} mpr = do let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped` - meta = mprToMeta mpr{ mppRecipient = userDisplayName u + meta = mprToMeta mpr{ mppExaminee = userDisplayName u -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB , mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour! } @@ -304,7 +304,7 @@ postPrintSendR = do let procFormSend mpr = do receivers <- runDB $ Ex.select $ do user <- Ex.from $ Ex.table @User - Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent) + Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent) pure user letters <- case receivers of [] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr) @@ -317,7 +317,7 @@ postPrintSendR = do -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" uID <- maybeAuthId - runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr + runDB (sendLetter' "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg @@ -447,4 +447,4 @@ postPrintAckDirectR = do let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored." $logErrorS "APC" msg return (badRequest400, msg) - sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back + sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index c26edd1ec..c54cd7854 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -13,8 +13,9 @@ module Handler.Utils.DateTime , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTimeRange, formatTimeRangeW, formatTimeRangeMail - , getTimeLocale, getDateTimeFormat - , getDateTimeFormatter, getDateTimeFormatterUser + , getTimeLocale + , getDateTimeFormat , getDateTimeFormatUser , getDateTimeFormatUser' + , getDateTimeFormatter, getDateTimeFormatterUser, getDateTimeFormatterUser' , validDateTimeFormats, dateTimeFormatOptions , addLocalDays , addDiffDaysClip, addDiffDaysRollOver @@ -127,6 +128,11 @@ getDateTimeFormatUser sel mUser = do SelFormatTime -> userDefaultTimeFormat return fmt +getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat +getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat +getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat +getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat + getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter getDateTimeFormatter = do locale <- getTimeLocale @@ -139,6 +145,13 @@ getDateTimeFormatterUser mUser = do formatMap <- traverse (`getDateTimeFormatUser` mUser) id return $ mkDateTimeFormatter locale formatMap appTZ +getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter +getDateTimeFormatterUser' usr = do + locale <- getTimeLocale + let formatMap = flip getDateTimeFormatUser' usr + return $ mkDateTimeFormatter locale formatMap appTZ + + validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon validDateTimeFormats tl SelFormatDateTime = Set.fromList $ diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index c375ee914..227e5ebf2 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -5,7 +5,7 @@ module Handler.Utils.Mail ( addRecipientsDB , userAddress, userAddressFrom - , userMailT + , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives , addHtmlMarkdownAlternatives' @@ -50,6 +50,7 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail +-- |Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m @@ -108,13 +109,13 @@ userMailT uid mAct = do addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email - -_userMailTdirect :: ( MonadHandler m +-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors +userMailTdirect :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m ) => UserId -> MailT m a -> m a -_userMailTdirect uid mAct = do +userMailTdirect uid mAct = do user@User { userLanguages , userDateTimeFormat diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index d75f41301..0fe21a898 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -13,6 +13,7 @@ module Handler.Utils.Users , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser , userPrefersEmail, userPrefersLetter + , getPostalAddress, getPostalPreferenceAndAddress , abbrvName , getReceivers ) where @@ -59,17 +60,36 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." +-- deprecated, used getPostalAddressIfPreferred userPrefersLetter :: User -> Bool -userPrefersLetter User{..} - = isJust userPostAddress && - ( userPrefersPostal || - isNothing userPinPassword || - Text.null (CI.original userEmail) - ) +userPrefersLetter = fst . getPostalPreferenceAndAddress +-- deprecated, used getPostalAddressIfPreferred userPrefersEmail :: User -> Bool userPrefersEmail = not . userPrefersLetter +-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known +getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) +getPostalPreferenceAndAddress usr@User{..} = + (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa) + where + orgEmail = CI.original userEmail + emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail) + postPossible = isJust pa + pa = getPostalAddress usr + +getPostalAddress :: User -> Maybe [Text] +getPostalAddress User{..} + | Just pa <- userPostAddress + = Just $ userDisplayName : html2textlines pa + | Just abt <- userCompanyDepartment + = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] + | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] + | otherwise + = Nothing + +-- | Return Entity User and all Supervisors with rerouteNotifications as well as +-- a boolean indicating if the user is own supervisor with rerouteNotifications getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) getReceivers uid = do underling <- getJustEntity uid diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index ef98d59b2..0409ed2f6 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -98,8 +98,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "login" lmsIdent , toMeta "pin" lmsUserPin - , toMeta "recipient" userDisplayName - , mbMeta "address" (prepAddress <$> userPostAddress) + , toMeta "examinee" userDisplayName + , mbMeta "address" (prepAddress <$> userPostAddress) -- TODO: this is buggy if there is no address set! , toMeta "expiry" expiryDate , mbMeta "validduration" (show <$> qualificationValidDuration) , toMeta "url-text" lmsUrl @@ -126,7 +126,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do notifyOk <- pdfRenewal pdfMeta >>= \case Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null let printSender = Nothing - in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case + in runDB (sendLetter' printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case Left err -> do let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err $logErrorS "LMS" msg diff --git a/src/Utils.hs b/src/Utils.hs index 8b74bbaf9..1fc7301fd 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -275,6 +275,10 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs -- tickmark :: IsString a => a -- tickmark = fromString "✔" +-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available +textElem :: Char -> Text -> Bool +textElem c = Text.any (c ==) + -- | remove all whitespace from Text -- whereas Text.strip only removes leading and trailing whitespace stripAll :: Text -> Text diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index be49ea741..4a1794c6b 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -6,12 +6,12 @@ module Utils.Print ( pdfRenewal - , sendLetter + , sendLetter, sendLetter' , encryptPDF , sanitizeCmdArg, validCmdArgument , templateDIN5008 , templateRenewal - -- , compileTemplate, makePDF + -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values , mkMeta, appMeta, applyMetas -- multiple values @@ -32,10 +32,15 @@ import qualified Text.Pandoc as P import qualified Text.Pandoc.PDF as P import qualified Text.Pandoc.Builder as P +import Text.Hamlet + import System.Exit import System.Process.Typed -- for calling pdftk for pdf encryption -import Handler.Utils.Users (abbrvName) +import Handler.Utils.Users +import Handler.Utils.DateTime +import Handler.Utils.Mail +import Jobs.Handler.SendNotification.Utils -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? @@ -105,14 +110,14 @@ appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs -- TODO: applyMetas is inconvenient since we cannot have an instance -- ToMetaValue a => ToMetaValue (Maybe a) --- so apply Metas +-- so apply Metas -- For tests see module PandocSpec 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 + where + act (_, Nothing) acc = acc + act (k, Just v ) acc = P.setMeta k v acc -- | Add meta to pandoc. Existing variables will be overwritten. @@ -151,7 +156,7 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat -- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text reTemplateLetter meta StoredMarkup{..} = do - tmpl <- compileTemplate strictMarkupInput + tmpl <- compileTemplate strictMarkupInput doc <- areader readerOpts strictMarkupInput let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } @@ -183,6 +188,18 @@ reTemplateLetter' meta md = do , P.readerStripComments = True } +mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) +mdTemplating template meta = runExceptT $ do + let readerOpts = def { P.readerExtensions = P.pandocExtensions + , P.readerStripComments = True + } + doc <- ExceptT $ $cachedHereBinary ("pandoc: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template) + tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl + } + ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang + $ addMeta meta doc --pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString @@ -263,13 +280,42 @@ pdfRenewal' meta = do pdfDIN5008' meta doc +-- Generic Version +pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString) +pdfLetter md meta = do + e_txt <- mdTemplating md meta + result <- actRight e_txt $ pdfDIN5008 meta + return $ over _Left P.renderError result + --------------- -- PrintJobs -- --------------- -sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) -sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do +data PrintJobIdentification = PrintJobIdentification + { pjiName :: Text + , pjiRecipient :: Maybe UserId + , pjiSender :: Maybe UserId + , pjiCourse :: Maybe CourseId + , pjiQualification :: Maybe QualificationId + , pjiLmsUser :: Maybe LmsIdent + } + deriving (Eq, Show) + +-- DEPRECATED +sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) +sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = + sendLetter pdf PrintJobIdentification + { pjiName = printJobName + , pjiRecipient = printJobRecipient + , pjiSender = printJobSender + , pjiCourse = printJobCourse + , pjiQualification = printJobQualification + , pjiLmsUser = printJobLmsUser + } + +sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath)) +sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse @@ -278,24 +324,24 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p nameSender = abbrvName <$> sender nameCourse = CI.original . courseShorthand <$> course nameQuali = CI.original . qualificationShorthand <$> quali - let jobFullName = text2asciiAlphaNum $ - T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) + let jobFullName = text2asciiAlphaNum $ + T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) printJobFilename = T.unpack $ jobFullName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code - printJobFile = LBS.toStrict pdf + printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing - lprPDF jobFullName pdf >>= \case - Left err -> do + lprPDF jobFullName pdf >>= \case + Left err -> do return $ Left err - Right ok -> do + Right ok -> do printJobCreated <- liftIO getCurrentTime -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows insert_ PrintJob {..} return $ Right (ok, printJobFilename) {- -sendLetter' :: _ -> DB PureFile -sendLetter' _ = do +sendLetter'' :: _ -> DB PureFile +sendLetter'' _ = do ... return $ File { fileTitle = printJobFilename , fileModified = printJobCreated @@ -308,47 +354,117 @@ sendLetter' _ = do data SomeUserTime where SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime -data ProtoMeta = IsMeta P.MetaValue - | IsTime SomeUserTime +data ProtoMeta = IsMeta P.MetaValue + | IsTime SomeUserTime convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue convertProto _ (IsMeta v) = v convertProto f (IsTime t) = P.toMetaValue $ f t --} +-} -class MDLetter l where - letterMeta :: l -> Languages -> DateTimeFormatter -> P.Meta - getTemplate :: Proxy l -> Text -- l -> Text might actually be easier to handle? +class MDLetter l where + getTemplate :: Proxy l -> Text + getSubject :: Proxy l -> SomeMessage UniWorX + letterMeta :: l -> Lang -> DateTimeFormatter -> P.Meta + getPJId :: l -> PrintJobIdentification -data LetterRenewQualification = LetterRenewQualification - { lmsLogin :: LmsIdent +data LetterRenewQualificationF = LetterRenewQualificationF + { lmsLogin :: LmsIdent , lmsPin :: Text + , qualId :: QualificationId + , qualHolder :: Text , qualExpiry :: Day , qualDuration :: Maybe Int } deriving (Eq, Show) -instance MDLetter LetterRenewQualification where +instance MDLetter LetterRenewQualificationF where getTemplate _ = templateRenewal - letterMeta LetterRenewQualification{..} _langs DateTimeFormatter{..} = mkMeta + getSubject _ = SomeMessage $ MsgMailSubjectQualificationRenewal "F" + letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta [ toMeta "login" lmsIdent , toMeta "pin" lmsPin + , toMeta "examinee" qualHolder , toMeta "expiry" (format SelFormatDate qualExpiry) , mbMeta "validduration" (show <$> qualDuration) , toMeta "url-text" lmsUrl , toMeta "url" lmsUrlLogin ] - where + where lmsUrl = "https://drive.fraport.de" lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin + getPJId LetterRenewQualificationF{..} = + PrintJobIdentification + { pjiName = "Renewal" + , pjiRecipient = Nothing -- to be filled later + , pjiSender = Nothing + , pjiCourse = Nothing + , pjiQualification = Just qualId + , pjiLmsUser = Just lmsLogin + } -{- --- sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m (?) -sendEmailOrLetter recipient letter = do - (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid - forM receivers $ \Entity --} +sendEmailOrLetter :: (MDLetter l) => UserId -> l -> m Bool +sendEmailOrLetter recipient letter = do + (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient + let tmpl = getTemplate $ pure letter + pjid = getPJId letter + now <- liftIO getCurrentTime + oks <- forM receivers $ \rcvr@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr + let (preferPost,postal) = getPostalPreferenceAndAddress rcvrUsr + -- continue here, since post = Nothing might happen here?! + lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang + lMeta = letterMeta letter lang formatter <> mkMeta + [ toMeta "lang" lang + , toMeta "date" $ format SelFormatDate now + , toMeta "address" $ fromMaybe (rcvrUsr & userDisplayName) postal + ] + pdfLetter tmpl lMeta >>= \case + _ | preferPost, isNothing postal -> do -- neither email nor postal is known + encRecipient :: CryptoUUIDUser <- encrypt svr + let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notfication: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Left err -> do -- pdf generation failed + encRecipient :: CryptoUUIDUser <- encrypt svr + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed. Notfication: " <> tshow pjid + $logErrorS "LETTER" msg + return False + Right pdf | preferPost -> -- send letter + runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case + Left err -> do + encRecipient :: CryptoUUIDUser <- encrypt svr + let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err + $logErrorS "LETTER" msg + return False + Right (msg,_) + | null msg -> return True + | otherwise -> do + $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg + return True + Right pdf -> do -- send email + attachment <- case userPinPassword rcvrUsr of + Nothing -> return pdf + Just passwd -> encryptPDF passwd pdf >>= \case + Right encPdf -> return encPdf + Left err -> do + encRecipient :: CryptoUUIDUser <- encrypt svr + let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err + $logWarnS "LETTER" msg + return pdf + userMailTdirect svr $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ getSubject $ pure letter + editNotifications <- mkEditNotifications svr + -- TODO: create generic template + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + addPart (File { fileTitle = T.unpack $ pjiName pjid + , fileModified = now + , fileContent = Just $ yield $ LBS.toStrict attachment + } :: PureFile) + return True + return $ or oks ----------------------------- @@ -371,10 +487,10 @@ readProcess' pc = do return (ec, st_err, st_out) -sanitizeCmdArg :: Text -> Text +sanitizeCmdArg :: Text -> Text sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) -- | Returns Nothing if ok, otherwise the first mismatching character --- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk +-- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk validCmdArgument :: Text -> Maybe Char validCmdArgument t = t `textDiff` sanitizeCmdArg t @@ -418,11 +534,11 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- | Internal only, use `sendLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) -lprPDF jb bs = do - lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg +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 + proc "lpr" $ + jobname ++ -- -J jobname -- a name for job identification at printing site [ lprServerArg -- -P queue@hostname:port , "-" -- read from stdin ] @@ -430,15 +546,15 @@ lprPDF jb bs = do | otherwise = ["-J " <> jb'] jb' = T.unpack $ sanitizeCmdArg jb exit2either <$> readProcess' pc - where - getLprServerArg = do + where + getLprServerArg = do LprConf{..} <- getsYesod $ view _appLprConf return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort {- -- Variant without caching lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text) -lprPDF' jb bs = do +lprPDF' jb bs = do LprConf{..} <- getsYesod $ view _appLprConf let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort pc = setStdin (byteStringInput bs) $ diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 283041d21..b00072a77 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -9,7 +9,7 @@ email: fahrerausbildung@fraport.de place: Frankfurt am Main return-address: - 60547 Frankfurt -de-opening: Sehr geehrte Damen und Herren, +de-opening: Liebe Fahrer, en-opening: Dear driver, de-closing: | Mit freundlichen Grüßen, @@ -30,7 +30,7 @@ is-de: true login: 123456 pin: abcdef # Emfpänger -recipient: E. M. Pfänger +examinee: E. M. Pfänger address: - Musterfirma GmbH - E. M. Pfänger @@ -53,17 +53,21 @@ $endfor$ $if(is-de)$ -die Gültigkeit Ihres Vorfeldführerscheins läuft demnächst ab, am $expiry$. -Durch die erfolgreiche Teilnahme an einem E-Learning können Sie die Gültigkeit +die Gültigkeit des Vorfeldführerscheins läuft demnächst ab. +Durch die erfolgreiche Teilnahme an einem E-Learning kann die Gültigkeit $if(validduration)$ um $validduration$ Monate $endif$ -verlängern. Verwenden Sie dazu die -Login-Daten aus dem geschützen Sichtfenster weiter unten. +verlängert werden. Dazu bitte die Login-Daten +aus dem geschützen Sichtfenster weiter unten verwenden. Prüfling - : $recipient$ + : $examinee$ + +Ablaufdatum + + : $expiry$ URL @@ -71,7 +75,7 @@ URL Sobald die Frist abgelaufen ist, muss zur Wiedererlangung der Fahrberechtigung "F" -erneut der Grundkurs bei der Fahrerausbildung absolviert werden. +erneut der komplette Grundkurs bei der Fahrerausbildung absolviert werden. Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden. @@ -80,8 +84,8 @@ $else$ -your apron diving license is about to expire soon, on $expiry$. -You can extend the validity +the apron diving license is about to expire soon. +The validity may be extended $if(validduration)$ by $validduration$ months $endif$ @@ -90,15 +94,19 @@ an e-learning. Please use the login data from the protected area below. Examinee - : $recipient$ + : $examinee$ + +Expiry + + : $expiry$ URL :[$url-text$]($url$) -Should your apron driving license expire before completing this -e-learning course, then a renewal requires your full participation +Should the apron driving license expire before completing this +e-learning, a later renewal then requires full participation of the basic training course again. diff --git a/testdata/test_letters.hs b/testdata/test_letters.hs index f1908d788..c138379e0 100644 --- a/testdata/test_letters.hs +++ b/testdata/test_letters.hs @@ -28,7 +28,7 @@ mdTmpl = "---\nfoo: fooOrg\nbar: barOrg\n---\nHere is some text\n - foo: $foo$\n -- Current Function found in Handler.PrintCenter, but is no longer exported! mprToMeta :: MetaPinRenewal -> P.Meta mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat - [ toMeta "recipient" mppRecipient + [ toMeta "examinee" mppExaminee , toMeta "address" (mppAddress & html2textlines) , toMeta "login" mppLogin , toMeta "pin" mppPin