diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 2a3a12987..9ce0d8ce3 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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 - 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 diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index c80957efc..3c3a0d862 100644 --- a/src/Handler/Utils/Download.hs +++ b/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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e019e5557..201469586 100644 --- a/src/Utils/Print.hs +++ b/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 - 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 diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 9f32946cb..c04d3f05c 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -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) <- diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 19b0549cd..2b4b94ac0 100644 --- a/src/Utils/Print/Letters.hs +++ b/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" diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index 537a8d8a8..fd953c40a 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/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]) } \ No newline at end of file diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 7402d9cd5..2ca22bfc5 100644 --- a/templates/letter/fraport_qualification.md +++ b/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$}}