refactor(letter): change pdf download for course certificates and filename generation

src/Handler/Tutorial/Users.hs

@@ -21,7 +21,7 @@ import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
--- import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy as LBS
 -- import qualified Data.Time.Zones as TZ
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -60,8 +60,7 @@ data TutorialUserActionData
 
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
 getTUsersR = postTUsersR
-postTUsersR tid ssh csh tutn = do
+postTUsersR tid ssh csh tutn = do  
-  showSex <- getShowSex
   (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
@@ -71,8 +70,7 @@ postTUsersR tid ssh csh tutn = do
         dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
+          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
-          , guardOn showSex colUserSex'
           , pure  colUserEmail
           , pure  colUserMatriclenr
           , pure  colUserQualifications
@@ -122,7 +120,7 @@ postTUsersR tid ssh csh tutn = do
     return (tutEnt, table, qualifications)
 
   let courseQids = Set.fromList (entityKey <$> qualifications)
-  formResult participantRes $ \case
+  tcontent <- formResultMaybe participantRes $ \case
     (TutorialUserPrintQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         rcvr <- requireAuth
@@ -132,13 +130,15 @@ postTUsersR tid ssh csh tutn = do
           [l] -> do
                   encRcvr <- encrypt $ entityKey rcvr
                   apcIdent <- letterApcIdent l encRcvr now
+                  let fName = letterFileName l
                   renderLetter rcvr l apcIdent >>= \case
-                    Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
+                    Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err                      
-                    Right pdf -> do -- void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now
+                    Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now
-                      let typePDF :: ContentType 
+                      -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-                          typePDF = "application/pdf"
+                      -- let typePDF :: ContentType 
-                      sendResponse (typePDF, toContent pdf)
+                      --     typePDF = "application/pdf"
-          _ -> addMessageI Error MsgErrorUnknownFormAction
+                      -- sendResponse (typePDF, toContent pdf)
+          _ -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
@@ -161,17 +161,19 @@ postTUsersR tid ssh csh tutn = do
           ]
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
         redirect $ CTutorialR tid ssh csh tutn TUsersR
-    _other -> 
+    _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
-        addMessageI Error MsgErrorUnknownFormAction
   
-  tutors <- runDB $ E.select $ do
+  case tcontent of 
-    (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
+    Just content -> return content -- abort and return produced content
-      `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
+    Nothing -> do
-    E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+      tutors <- runDB $ E.select $ do
-    return user
+        (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
+          `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
+        E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+        return user
 
-  let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
+      let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
-  html <- siteLayoutMsg heading $ do
+      html <- siteLayoutMsg heading $ do
-    setTitleI heading
+        setTitleI heading
-    $(widgetFile "tutorial-participants")
+        $(widgetFile "tutorial-participants")
-  return $ toTypedContent html
+      return $ toTypedContent html

src/Handler/Utils/Download.hs

@@ -4,7 +4,8 @@
 
 module Handler.Utils.Download
   ( sendThisFile
-  , sendByteStringAsFile
+  , sendByteStringAsFile --, sendByteStringAsFileAndExit
+  , sendResponseByteStringFile
   , sendFileReference
   , serveOneFile
   , serveSomeFiles
@@ -176,6 +177,37 @@ sendByteStringAsFile fileTitle content fileModified =
       | null content = Nothing 
       | otherwise    = Just $ yield content
 
+-- THIS DOES NOT WORK:
+-- sendByteStringAsFileAndExit :: ( YesodAuthPersist UniWorX
+--                 , AuthEntity UniWorX ~ User
+--                 , AuthId UniWorX ~ UserId
+--                 , YesodPersistRunner UniWorX
+--                 , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
+--                 ) => FilePath -> ByteString -> UTCTime -> HandlerFor UniWorX a
+-- sendByteStringAsFileAndExit fileTitle content fileModified= do 
+--   void $ sendByteStringAsFile fileTitle content fileModified
+--   sendResponse ()
+
+
+-- | like sendByteStringAsFile, but uses sendResponse instead of respondSourceDB, ensuring that
+--   remaining handler code is bybassed
+sendResponseByteStringFile :: -- ( YesodAuthPersist UniWorX
+                -- , AuthEntity UniWorX ~ User
+                -- , AuthId UniWorX ~ UserId                
+                -- , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
+                -- ) => 
+                FilePath -> ByteString -> HandlerFor UniWorX a
+sendResponseByteStringFile fileTitle fileContent = do 
+  -- ensureApprootUserGeneratedMaybe' Nothing
+  when (null fileContent) $ sendResponseStatus noContent204 ()
+  let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
+      content = (cType, toContent fileContent)
+  -- setCSPSandbox
+  setContentDisposition ContentInline $ Just $ takeFileName fileTitle  -- just displays, but cannot save
+  -- setContentDisposition ContentAttachment $ Just $ takeFileName fileTitle -- saves file pnly, no display
+  -- setContentDisposition' . Just $ takeFileName fileTitle
+  sendResponse content
+
 sendFileReference :: forall file a.
                      ( HasFileReference file
                      , BearerAuthSite UniWorX

src/Utils/Print.hs

@@ -9,14 +9,16 @@ module Utils.Print
   , sendEmailOrLetter   -- directly print or sends by email
   , printLetter         -- always send a letter
   , letterApcIdent      -- create acknowledge string for APC
+  , letterFileName      -- default filename
   , encryptPDF
-  , sanitizeCmdArg, validCmdArgument
+  , sanitizeCmdArg, sanitizeCmdArg', validCmdArgument
   -- , compileTemplate, makePDF
   , _Meta, addMeta
   , toMeta, mbMeta                           -- single values
-  , mkMeta, appMeta, applyMetas              -- multiple values
+  , mkMeta, appMeta, applyMetas              -- multiple values    
   , LetterRenewQualificationF(..)
-  , LetterCourseCertificate(), makeCourseCertificates
+  -- , LetterCourseCertificate()
+  , makeCourseCertificates
   ) where
 
 -- import Import.NoModel
@@ -185,22 +187,13 @@ printLetter' pji pdf = do
         , pjiCourse         = printJobCourse
         , pjiQualification  = printJobQualification
         , pjiLmsUser        = printJobLmsUser
+        , pjiFileName       = fName
         } = pji
-  recipient <- join <$> mapM get printJobRecipient
+      printJobFilename = T.unpack $ text2asciiAlphaNum fName <> ".pdf"
-  sender    <- join <$> mapM get printJobSender
-  course    <- join <$> mapM get printJobCourse
-  quali     <- join <$> mapM get printJobQualification
-  let nameRecipient = abbrvName <$> recipient
-      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])
-      printJobFilename     = T.unpack $ jobFullName <> ".pdf"
       -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf   -- for PrintJobFile :: FileContentReference use this code
       printJobFile = LBS.toStrict pdf
       printJobAcknowledged = Nothing
-  lprPDF jobFullName pdf >>= \case
+  lprPDF printJobFilename pdf >>= \case
     Left err -> do
       return $ Left err
     Right ok -> do
@@ -223,7 +216,8 @@ sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool
 sendEmailOrLetter recipient letter = do
   (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
   now <- liftIO getCurrentTime
-  let pjid = getPJId letter
+  let pjid  = getPJId letter
+      fName = letterFileName letter
       mailSubject = getMailSubject letter       -- these are only needed if sent by email, but we're lazy anyway
       undername = underling ^. _userDisplayName -- nameHtml' underling
       undermail = CI.original $ underling ^. _userEmail
@@ -274,7 +268,7 @@ sendEmailOrLetter recipient letter = do
           setSubjectI mailSubject
           editNotifications <- mkEditNotifications svr
           addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet")
-          addPart (File { fileTitle     = T.unpack $ pjiName pjid <> ".pdf"
+          addPart (File { fileTitle     = fName
                         , fileModified  = now
                         , fileContent   = Just $ yield $ LBS.toStrict attachment
                         } :: PureFile)
@@ -304,6 +298,10 @@ readProcess' pc = do
 
 sanitizeCmdArg :: Text -> Text
 sanitizeCmdArg =  T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c))
+
+sanitizeCmdArg' :: String -> String
+sanitizeCmdArg' =  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
 validCmdArgument :: Text -> Maybe Char
@@ -348,8 +346,8 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 --  > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName -
 
 -- | Internal only, use `printLetter` instead
-lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text)
+lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
-lprPDF jb bs = do
+lprPDF (sanitizeCmdArg' -> jb) bs = do
     mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
     case mbLprServerArg of
       Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
@@ -361,8 +359,7 @@ lprPDF jb bs = do
                     , "-"                                           -- read from stdin
                     ]
             jobname | null jb   = []
-                    | otherwise = ["-J " <> jb']
+                    | otherwise = ["-J " <> jb]            
-            jb' = T.unpack $ sanitizeCmdArg jb
         exit2either <$> readProcess' pc
   where
     getLprServerArg = do

src/Utils/Print/CourseCertificate.hs

@@ -19,8 +19,10 @@ import Handler.Utils.Profile
 
 data LetterCourseCertificate = LetterCourseCertificate
     { ccCourseId          :: CourseId
-    , ccCourseName        :: Text
+    , ccCourseName        :: Text    
-    -- , ccTutorialName      :: Text
+    , ccCourseShorthand   :: Text 
+    , ccCourseSchool      :: Text
+    , ccTutorialName      :: Text 
     , ccCourseContent     :: Maybe [Text]
     , ccCourseBegin       :: Maybe Day
     , ccCourseEnd         :: Maybe Day
@@ -64,16 +66,22 @@ instance MDLetter LetterCourseCertificate where
       , pjiCourse           = Just ccCourseId
       , pjiQualification    = Nothing
       , pjiLmsUser          = Nothing
+      , pjiFileName         = "cert_" <> ccCourseSchool <> "-" <> ccCourseShorthand <> "-" <> ccTutorialName
       }
 
 
 makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate)
-makeCourseCertificates tut ccCourseLang participants = do
+makeCourseCertificates Tutorial{ tutorialName   = CI.original -> ccTutorialName
-  let ccCourseId = tut ^. _tutorialCourse
+                               , tutorialCourse =                ccCourseId
-  Course{courseName, courseDescription} <- get404 ccCourseId
+                               , tutorialTime   = occurrences
-  let ccCourseName = CI.original courseName
+                               } ccCourseLang participants = do
-      ccCourseContent = html2textlines <$> courseDescription
+  Course{ courseName        = CI.original               -> ccCourseName
-      (ccCourseBegin, ccCourseEnd) = occurrencesBounds $ tut ^. _tutorialTime      
+        , courseShorthand   = CI.original               -> ccCourseShorthand
+        , courseSchool      = CI.original . unSchoolKey -> ccCourseSchool
+        , courseDescription = fmap html2textlines       -> ccCourseContent
+        } <- get404 ccCourseId
+  let (ccCourseBegin, ccCourseEnd') = occurrencesBounds occurrences
+      ccCourseEnd = bool ccCourseEnd' Nothing $ ccCourseBegin == ccCourseEnd
   forM participants $ \uid -> do
     User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid    
     (ccFraNumber, ccFraDepartment, ccCompany) <- 

src/Utils/Print/Letters.hs

@@ -174,6 +174,7 @@ data PrintJobIdentification = PrintJobIdentification
       , pjiCourse         :: Maybe CourseId
       , pjiQualification  :: Maybe QualificationId
       , pjiLmsUser        :: Maybe LmsIdent
+      , pjiFileName       :: Text -- suggested filename, without suffix ".pdf"
       }
   deriving (Eq, Show)
 
@@ -234,6 +235,9 @@ letterApcIdent l uuid now = do
   tnow <- formatTime' "%y%m%d-%H" now
   return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l)
 
+letterFileName :: (MDLetter l) => l -> FilePath
+letterFileName = Text.unpack . (<> ".pdf") . text2asciiAlphaNum . pjiFileName . getPJId
+
 addApcIdent :: Text -> P.Meta
 addApcIdent = P.Meta . toMeta "apc-ident"
 

src/Utils/Print/RenewQualification.hs

@@ -86,4 +86,10 @@ instance MDLetter LetterRenewQualificationF where
       , pjiCourse           = Nothing
       , pjiQualification    = Just qualId
       , pjiLmsUser          = Just lmsLogin
+      , pjiFileName         = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN 
+        -- let nameRecipient = abbrvName <$> recipient
+        --     nameSender    = abbrvName <$> sender
+        --     nameCourse    = CI.original . courseShorthand        <$> course
+        --     nameQuali     = CI.original . qualificationShorthand <$> quali
+        -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
       }

templates/letter/fraport_qualification.md

@@ -29,7 +29,11 @@ $if(company)$
 $endif$
 hat
 $if(course-begin)$
+$if(course-end)$
 von $course-begin$ bis $course-end$
+$else$
+am $course-begin$
+$endif$
 $endif$
 an der Veranstaltung  
 \centerline{\sffamily\LARGE{$course-name$}}