fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2023-04-06 12:56:59 +00:00
parent 879b8a72be
commit 5f536864a5
7 changed files with 107 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
src/Handler/Tutorial/Users.hs
View File

@ -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
showSex <- getShowSex
postTUsersR tid ssh csh tutn = do
(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
, guardOn showSex colUserSex'
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
, 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
Right pdf -> do -- void $ sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now
let typePDF :: ContentType
typePDF = "application/pdf"
sendResponse (typePDF, toContent pdf)
_ -> addMessageI Error MsgErrorUnknownFormAction
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-- let typePDF :: ContentType
-- typePDF = "application/pdf"
-- 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 ->
addMessageI Error MsgErrorUnknownFormAction
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
tutors <- runDB $ E.select $ do
(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
case tcontent of
Just content -> return content -- abort and return produced content
Nothing -> do
tutors <- runDB $ E.select $ do
(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
html <- siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")
return $ toTypedContent html
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
html <- siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")
return $ toTypedContent html

34
src/Handler/Utils/Download.hs
View File

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

39
src/Utils/Print.hs
View File

@ -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
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"
printJobFilename = T.unpack $ text2asciiAlphaNum fName <> ".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 jb bs = do
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
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']
jb' = T.unpack $ sanitizeCmdArg jb
| otherwise = ["-J " <> jb]
exit2either <$> readProcess' pc
where
getLprServerArg = do

24
src/Utils/Print/CourseCertificate.hs
View File

@ -19,8 +19,10 @@ import Handler.Utils.Profile
data LetterCourseCertificate = LetterCourseCertificate
{ ccCourseId :: CourseId
, ccCourseName :: Text
-- , ccTutorialName :: Text
, ccCourseName :: 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
let ccCourseId = tut ^. _tutorialCourse
Course{courseName, courseDescription} <- get404 ccCourseId
let ccCourseName = CI.original courseName
ccCourseContent = html2textlines <$> courseDescription
(ccCourseBegin, ccCourseEnd) = occurrencesBounds $ tut ^. _tutorialTime
makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName
, tutorialCourse = ccCourseId
, tutorialTime = occurrences
} ccCourseLang participants = do
Course{ courseName = CI.original -> ccCourseName
, 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) <-

4
src/Utils/Print/Letters.hs
View File

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

6
src/Utils/Print/RenewQualification.hs
View File

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

4
templates/letter/fraport_qualification.md
View File

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