fix(mail): fix #179 by adding download links for PDF attachments
This commit is contained in:
parent
f0798e8836
commit
620e3e4700
@ -153,6 +153,7 @@ MenuCommCenter: Benachrichtigungen
|
||||
MenuMailCenter: E‑Mails
|
||||
MenuMailHtml !ident-ok: Html
|
||||
MenuMailPlain !ident-ok: Text
|
||||
MenuMailAttachment: Anhang
|
||||
|
||||
MenuApiDocs: API-Dokumentation (Englisch)
|
||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||
|
||||
@ -153,6 +153,7 @@ MenuCommCenter: Notifications
|
||||
MenuMailCenter: Email
|
||||
MenuMailHtml: Html
|
||||
MenuMailPlain: Text
|
||||
MenuMailAttachment: Attachment
|
||||
|
||||
MenuApiDocs: API documentation
|
||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
|
||||
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
|
||||
InvalidEmailAddress: E-Mail-Adresse ist ungültig
|
||||
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
|
||||
MailFileAttachment: Dateianhang
|
||||
UtilExamResultGrade: Note
|
||||
UtilExamResultPass: Bestanden/Nicht Bestanden
|
||||
UtilExamResultNoShow: Nicht erschienen
|
||||
|
||||
@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
|
||||
AmbiguousEmail: Email address is ambiguous
|
||||
InvalidEmailAddress: Email address is invalid
|
||||
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
|
||||
MailFileAttachment: Attached file
|
||||
UtilExamResultGrade: Grade
|
||||
UtilExamResultPass: Passed/Failed
|
||||
UtilExamResultNoShow: Not present
|
||||
|
||||
1
routes
1
routes
@ -82,6 +82,7 @@
|
||||
/comm/email MailCenterR GET POST
|
||||
/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET
|
||||
/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET
|
||||
/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
|
||||
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
||||
|
||||
@ -134,6 +134,7 @@ breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing
|
||||
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR
|
||||
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
|
||||
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
|
||||
breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
|
||||
@ -8,6 +8,7 @@ module Handler.MailCenter
|
||||
( getMailCenterR, postMailCenterR
|
||||
, getMailHtmlR
|
||||
, getMailPlainR
|
||||
, getMailAttachmentR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -163,6 +164,27 @@ postMailCenterR = do
|
||||
$(widgetFile "mail-center")
|
||||
|
||||
|
||||
typePDF :: ContentType
|
||||
typePDF = "application/pdf"
|
||||
|
||||
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
|
||||
getMailAttachmentR cusm attdisp = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDBRead $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getAttm alts = case selectAlternative [typePDF] alts of
|
||||
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
|
||||
| t == attdisp
|
||||
-> Just pc
|
||||
_ -> Nothing
|
||||
attm = firstJust getAttm mcontent
|
||||
case attm of
|
||||
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
|
||||
_ -> notFound
|
||||
|
||||
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
|
||||
|
||||
@ -216,8 +238,7 @@ handleMailShow hdr prefTypes cusm = do
|
||||
<section>
|
||||
$forall mc <- mcontent
|
||||
$maybe pt <- selectAlternative prefTypes mc
|
||||
<p>
|
||||
^{part2widget pt}
|
||||
^{part2widget cusm pt}
|
||||
|]
|
||||
-- Include for Debugging:
|
||||
-- <section>
|
||||
@ -238,23 +259,22 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
|
||||
aux _ [] = Nothing
|
||||
|
||||
disposition2widget :: Disposition -> Widget
|
||||
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
|
||||
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
|
||||
disposition2widget DefaultDisposition = mempty
|
||||
|
||||
part2widget :: Part -> Widget
|
||||
part2widget Part{partContent=NestedParts ps} =
|
||||
part2widget :: CryptoUUIDSentMail -> Part -> Widget
|
||||
part2widget cusm Part{partContent=NestedParts ps} =
|
||||
[whamlet|
|
||||
<section>
|
||||
$forall p <- ps
|
||||
<p>
|
||||
^{part2widget p}
|
||||
^{part2widget cusm p}
|
||||
|]
|
||||
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
||||
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
||||
[whamlet|
|
||||
<section>
|
||||
^{disposition2widget dispo}
|
||||
^{showBody}
|
||||
^{showPass}
|
||||
|]
|
||||
where
|
||||
showBody
|
||||
@ -263,8 +283,25 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD
|
||||
| pt == decodeUtf8 typeJson =
|
||||
let jw :: Aeson.Value -> Widget = jsonWidget
|
||||
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
|
||||
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
|
||||
|
||||
| pt == decodeUtf8 typePDF
|
||||
, AttachmentDisposition t <- dispo
|
||||
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
|
||||
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
|
||||
showPass
|
||||
| pt == decodeUtf8 typePlain
|
||||
, Just name <- listBracket ("Inhaber","Gültig") $ T.words (decodeUtf8 pc)
|
||||
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
|
||||
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
|
||||
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
|
||||
Just Entity{entityVal = User{userPinPassword=mbpw}} ->
|
||||
[whamlet|
|
||||
<section>
|
||||
$maybe pw <- mbpw
|
||||
_{MsgAdminUserPinPassword}: #{pw}
|
||||
$nothing
|
||||
_{MsgAdminUserNoPassword}
|
||||
|]
|
||||
| otherwise = mempty
|
||||
|
||||
------------------------------
|
||||
-- Decode MIME Encoded Word
|
||||
|
||||
13
src/Utils.hs
13
src/Utils.hs
@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
|
||||
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
|
||||
checkAsc _ = True
|
||||
|
||||
-- return a part of a list between two given elements, if it exists
|
||||
listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
|
||||
listBracket _ [] = Nothing
|
||||
listBracket b@(s,e) (h:t)
|
||||
| s == h = listUntil [] t
|
||||
| otherwise = listBracket b t
|
||||
where
|
||||
listUntil _ [] = Nothing
|
||||
listUntil l1 (h1:t1)
|
||||
| e == h1 = Just $ reverse l1
|
||||
| otherwise = listUntil (h1:l1) t1
|
||||
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
----------
|
||||
|
||||
@ -113,10 +113,10 @@ fillDb = do
|
||||
, userMobile = Nothing
|
||||
, userCompanyPersonalNumber = Just "00000"
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPinPassword = Just "1234.5"
|
||||
, userPostAddress = Just $ markdownToStoredMarkup ("Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München"::Text)
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = True
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -202,7 +202,7 @@ fillDb = do
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = True
|
||||
, userPrefersPostal = False
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -220,7 +220,7 @@ fillDb = do
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = 7
|
||||
, userTheme = ThemeAberdeenReds
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateTimeFormat = userDefaultDateTimeFormatprefersPo
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -766,7 +766,7 @@ fillDb = do
|
||||
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates!
|
||||
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
|
||||
void . insert' $ QualificationUser jost qid_rp (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
|
||||
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9)
|
||||
qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 10) (n_day $ -40) (n_day $ -120) True (n_day' $ -20)
|
||||
void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel)
|
||||
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1)
|
||||
qfvaupel <- insert' $ QualificationUser svaupel qid_f (n_day 2) (n_day $ -1) (n_day $ -2) True (n_day' $ -9)
|
||||
|
||||
Reference in New Issue
Block a user