fix(mail): fix #179 by adding download links for PDF attachments

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -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)

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -153,6 +153,7 @@ MenuCommCenter: Notifications
 MenuMailCenter: Email
 MenuMailHtml: Html
 MenuMailPlain: Text
+MenuMailAttachment: Attachment
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/utils/de-de-formal.msg

@@ -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

messages/uniworx/utils/utils/en-eu.msg

@@ -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

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

src/Foundation/Navigation.hs

@@ -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

src/Handler/MailCenter.hs

@@ -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 cusm pt}
-              ^{part2widget 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 (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
 disposition2widget  DefaultDisposition       = mempty
 
-part2widget :: Part -> Widget
+part2widget :: CryptoUUIDSentMail -> Part -> Widget
-part2widget Part{partContent=NestedParts ps} =
+part2widget cusm Part{partContent=NestedParts ps} =
   [whamlet|
-    <section>
       $forall p <- ps
-        <p>
+        ^{part2widget cusm p}
-          ^{part2widget 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

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 --
 ----------

test/Database/Fill.hs

@@ -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)