chore(letter): generalizing letter sending (WIP)
This commit is contained in:
Steffen Jost
parent
2cdc5530ad
commit
a7949aba9c
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 $
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) $
|
||||
|
||||
@ -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)$
|
||||
|
||||
<!-- deutsche Version des Briefes -->
|
||||
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$
|
||||
|
||||
<!-- englische Version des Briefes -->
|
||||
|
||||
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.
|
||||
|
||||
|
||||
|
||||
2
testdata/test_letters.hs
vendored
2
testdata/test_letters.hs
vendored
@ -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
|
||||
|
||||
Reference in New Issue
Block a user