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

Merge remote-tracking branch 'origin/fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-04-06 18:10:13 +02:00
commit ac22ab2942
24 changed files with 418 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -107,7 +107,6 @@ CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen voll
CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
CampusUserInvalidMatriculation: Konnte anhand des Fraport Büko-Logins keine Matrikelnummer ermitteln
CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Institute ermitteln
InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht

1
messages/uniworx/categories/authorization/en-eu.msg
View File

@ -108,7 +108,6 @@ CampusUserInvalidDisplayName: Could not determine display name during Fraport B
CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login
CampusUserInvalidSurname: Could not determine surname during Fraport Büko login
CampusUserInvalidTitle: Could not determine title during Fraport Büko login
CampusUserInvalidMatriculation: Could not determine matriculation during Fraport Büko login
CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
InvalidCredentialsADNoSuchObject: User entry does not exist

2
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -132,7 +132,7 @@ CourseUserTutorials: Angemeldete Tutorien
CourseUserExams: Angemeldete Prüfungen
CourseUserSheets: Übungsblätter
CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin
CsvColumnUserMatriculation: Matrikelnummer des/der Teilnehmers/Teilnehmerin
CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin
CsvColumnUserSex: Geschlecht
CsvColumnUserBirthday: Geburtstag
CsvColumnUserEmail: E-Mail-Adresse des/der Teilnehmers/Teilnehmerin

2
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -132,7 +132,7 @@ CourseUserTutorials: Registered tutorials
CourseUserExams: Registered exams
CourseUserSheets: Exercise sheets
CsvColumnUserName: Participant's full name
CsvColumnUserMatriculation: Participant's matriculation
CsvColumnUserMatriculation: Participant's AVS number
CsvColumnUserSex: Participant's sex
CsvColumnUserBirthday: Birthday
CsvColumnUserEmail: Participant's email address

2
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -11,7 +11,7 @@ AdminUserDisplayEmail: E-Mail-Adresse
AdminUserIdent: Identifikation
AdminUserAuth: Authentifizierung
AdminUserAuthTooltip: Abhängig von der Auswahl werden neue Benutzer über ihr neues FRADrive Konto benachrichtigt.
AdminUserMatriculation: Matrikelnummer
AdminUserMatriculation: AVS Nummer
AdminUserSex: Geschlecht
AdminUserBirthday: Geburtsdatum
AdminUserTelephone: Telefonnummer

2
messages/uniworx/categories/user/en-eu.msg
View File

@ -11,7 +11,7 @@ AdminUserDisplayEmail: Email address
AdminUserIdent: Identification
AdminUserAuth: Authentication
AdminUserAuthTooltip: New users may be notified about their FRADrive account depending on this choice.
AdminUserMatriculation: Matriculation
AdminUserMatriculation: AVS number
AdminUserSex: Sex
AdminUserBirthday: Date of Birth
AdminUserTelephone: Phone

2
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -56,7 +56,7 @@ TableTutorialDeregisterUntil: Deregister until
TableActionsHead: Actions
TableTutorialTime: Time
TableNoFilter: No restriction
TableUserMatriculation: AVS Number
TableUserMatriculation: AVS number
TableColumnStudyFeatures: Features of study
TableSchoolShort: Shorthand
TableSchoolName: Name

2
src/Foundation/Yesod/Auth.hs
View File

@ -127,7 +127,7 @@ data CampusUserConversionException
| CampusUserInvalidGivenName
| CampusUserInvalidSurname
| CampusUserInvalidTitle
| CampusUserInvalidMatriculation
-- | CampusUserInvalidMatriculation
| CampusUserInvalidFeaturesOfStudy Text
| CampusUserInvalidAssociatedSchools Text
deriving (Eq, Ord, Read, Show, Generic)

1
src/Handler/Admin/Avs.hs
View File

@ -367,7 +367,6 @@ getProblemAvsSynchR = do
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
-- TODO: for all ids, uery PersonStatus and create a Map from AvsId to a List of all valid Cards
--
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->

12
src/Handler/SAP.hs
View File

@ -13,6 +13,7 @@ import Import
import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.Profile
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Csv as Csv
@ -56,11 +57,11 @@ instance ToNamedRecord SapUserTableCsv where
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
-- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l
, let persNoAsInt = readMay persNo
, persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export
, persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export
, let res = SapUserTableCsv
sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l
-- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber
-- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export
-- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export
, let res = SapUserTableCsv
{ csvSUTpersonalNummer = persNo
, csvSUTqualifikation = sapId
, csvSUTgültigVon = firstHeld
@ -68,6 +69,7 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val
-- , csvSUTsupendiertBis = blocked
, csvSUTausprägung = "J"
}
, validFraportPersonalNumber pn
]
-- | Deliver all employess with a successful LDAP synch within the last 3 months

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

@ -11,6 +11,7 @@ module Handler.Tutorial.Users
import Import
import Utils.Form
import Utils.Print
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial
@ -20,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.Time.Zones as TZ
import Database.Esqueleto.Experimental ((:&)(..))
@ -57,21 +58,19 @@ data TutorialUserActionData
deriving (Eq, Ord, Read, Show, Generic)
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
showSex <- getShowSex
(Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
postTUsersR tid ssh csh tutn = do
(Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- getCourseQualifications cid
now <- liftIO getCurrentTime
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
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
@ -118,14 +117,29 @@ postTUsersR tid ssh csh tutn = do
, ( TutorialUserDeregister, pure TutorialUserDeregisterData )
]
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
return (tut, table, qualifications)
return (tutEnt, table, qualifications)
let courseQids = Set.fromList (entityKey <$> qualifications)
formResult participantRes $ \case
(TutorialUserPrintQualificationData{..}, _selectedUsers)
tcontent <- formResultMaybe participantRes $ \case
(TutorialUserPrintQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
-- TODO Continue here
addMessageI Error MsgErrorUnknownFormAction
rcvr <- requireAuth
encRcvr <- encrypt $ entityKey rcvr
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
let mbAletter = anyone letters
case mbAletter of
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
Just aletter -> do
now <- liftIO getCurrentTime
apcIdent <- letterApcIdent aletter encRcvr now
let fName = letterFileName aletter
renderLetters rcvr letters apcIdent >>= \case
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)
(TutorialUserGrantQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
@ -148,16 +162,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
siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
html <- siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")
return $ toTypedContent html

9
src/Handler/Utils/Avs.hs
View File

@ -241,7 +241,14 @@ retrieveDifferingLicences' getStatus = do
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
let statQry = avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus && notNull statQry then throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
lStat <- if getStatus && notNull statQry
then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler
avsQueryStatus (AvsQueryStatus statQry) >>= \case
Left err -> do
addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
return $ AvsResponseStatus mempty
Right res -> return res
else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
#endif
return (lDiff, avsResponseStatusMap lStat)

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

17
src/Handler/Utils/Profile.hs
View File

@ -5,12 +5,10 @@
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
-- TODO: consider merging with Handler.Utils.Users?
module Handler.Utils.Profile
( checkDisplayName
, validDisplayName
, fixDisplayName
( validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress
, validEmail, validEmail'
, pickValidEmail, pickValidEmail'
, validEmail, validEmail', pickValidEmail, pickValidEmail'
, validFraportPersonalNumber
) where
import Import.NoFoundation
@ -103,4 +101,11 @@ pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
pickValidEmail' x y
| validEmail' x = Just x
| validEmail' y = Just y
| otherwise = Nothing
| otherwise = Nothing
validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t)
| (Just pn) <- readMay t
= pn >= (10000::Int) && pn <= (99999::Int) -- used to filter for SAP export
| otherwise = False

14
src/Model/Types/DateTime.hs
View File

@ -15,6 +15,7 @@ module Model.Types.DateTime
import Import.NoModel
import qualified Data.Set as Set
import Data.Ratio ((%))
import qualified Data.Text as Text
-- import Data.Either.Combinators (maybeToRight, mapLeft)
@ -206,3 +207,16 @@ derivePersistFieldJSON ''Occurrences
nullaryPathPiece ''DayOfWeek camelToPathPiece
-- | Get bounds for an Occurrences
-- TODO: unfinished function, only works for a few selected cases yet
occurrencesBounds :: Occurrences -> (Maybe Day, Maybe Day)
occurrencesBounds Occurrences{occurrencesScheduled=scd} | notNull scd = (Nothing, Nothing) -- TODO: case is not yet implemented
occurrencesBounds Occurrences{occurrencesExceptions=exc} = (Set.lookupMin occDays, Set.lookupMax occDays)
where
occDays = Set.foldr getOccDays mempty exc
getOccDays :: OccurrenceException -> Set Day -> Set Day
getOccDays ExceptNoOccur{} acc = acc -- TODO: this case ignores ExceptNoOccur for now!
getOccDays ExceptOccur{exceptDay} acc = Set.insert exceptDay acc

11
src/Utils.hs
View File

@ -845,6 +845,11 @@ toNothing = const Nothing
toNothingS :: String -> Maybe b
toNothingS = const Nothing
-- | change second of maybe pair to Nothing, if both are Just and equal
eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a)
eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing)
eq2nothing p = p
-- replaced by a more general formulation, see canonical
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-- null2nothing (Just x) | null x = Nothing
@ -1297,6 +1302,12 @@ maxLength :: ( Integral n
-- ^ @maxLegth n xs = length xs <= n@
maxLength l = not . minLength (succ l)
-- anyone :: (Foldable t) => t a -> Maybe a
-- | return any single element from a foldable, if it is not null
anyone :: (Foldable t, Alternative f) => t a -> f a
anyone = Fold.foldr ((<|>).pure) empty
------------
-- Writer --
------------

3
src/Utils/Lens.hs
View File

@ -128,6 +128,9 @@ makeClassyFor_ ''LmsResult
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard
makeClassyFor_ ''UserCompany
makeLenses_ ''Company
_entityKey :: Getter (Entity record) (Key record)
-- ^ Not a `Lens'` for safety
_entityKey = to entityKey

102
src/Utils/Print.hs
View File

@ -6,16 +6,20 @@
module Utils.Print
( renderLetter -- used for generating letter pdfs
, renderLetters
, 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
) where
-- import Import.NoModel
@ -47,6 +51,7 @@ import Jobs.Handler.SendNotification.Utils
import Utils.Print.Letters
import Utils.Print.RenewQualification
import Utils.Print.CourseCertificate
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
@ -103,7 +108,7 @@ import Utils.Print.RenewQualification
-- | read and writes markdown, applying it as its own template to apply meta
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc)
mdTemplating template meta = runExceptT $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True
@ -113,21 +118,20 @@ mdTemplating template meta = runExceptT $ do
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl
}
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta doc
ExceptT . pure . P.runPure $ do
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
P.readMarkdown readerOpts md_txt
-- | creates a PDF using a LaTeX template
pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfLaTeX lk meta md = do
pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfLaTeX lk doc = do
e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions }
writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl }
doc <- P.readMarkdown readerOpts md
makePDF writerOpts
$ appMeta setIsDeFromLang
$ addMeta meta doc
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl }
makePDF writerOpts $ appMeta setIsDeFromLang doc
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
@ -136,20 +140,49 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
kind = getLetterKind $ pure mdl
tmpl = getTemplate $ pure mdl
tmpl = getTemplate mdl
meta = addApcIdent apcIdent
<> letterMeta mdl formatter lang rcvrEnt
<> mkMeta
[ toMeta "lang" lang
, toMeta "date" $ format SelFormatDate now
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
toMeta "date" $ format SelFormatDate now
, toMeta "rcvr-name" $ rcvr & userDisplayName
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
]
e_md <- mdTemplating tmpl meta
result <- actRight e_md $ pdfLaTeX kind meta
result <- actRight e_md $ pdfLaTeX kind
return $ over _Left P.renderError result
-- TODO: apcIdent does not make sense for multiple letters
renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)
renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
| Just l <- anyone mdls = do
now <- liftIO getCurrentTime
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
kind = getLetterKind $ pure l
templateCombine _ err@Left{} = pure err
templateCombine mdl (Right doc1) =
let tmpl = getTemplate mdl
meta = addApcIdent apcIdent
<> letterMeta mdl formatter lang rcvrEnt
<> mkMeta
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
toMeta "date" $ format SelFormatDate now
, toMeta "rcvr-name" $ rcvr & userDisplayName
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
]
in mdTemplating tmpl meta >>= \case
err@Left{} -> pure err
Right doc2 -> pure $ Right $ doc1 <> doc2
doc <- foldrM templateCombine (Right mempty) mdls
result <- actRight doc $ pdfLaTeX kind
return $ over _Left P.renderError result
| otherwise = return $ Left "renderLetters received empty set of letters"
---------------
@ -183,22 +216,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
@ -217,11 +241,12 @@ printLetter'' _ = do
}
-}
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
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
@ -272,7 +297,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)
@ -302,6 +327,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
@ -346,8 +375,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."
@ -359,8 +388,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

95
src/Utils/Print/CourseCertificate.hs Normal file
View File

@ -0,0 +1,95 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print.CourseCertificate where
import Import
-- import Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile)
import Utils.Print.Letters
import Handler.Utils.Profile
data LetterCourseCertificate = LetterCourseCertificate
{ ccCourseId :: CourseId
, ccCourseName :: Text
, ccCourseShorthand :: Text
, ccCourseSchool :: Text
, ccTutorialName :: Text
, ccCourseContent :: Maybe [Text]
, ccCourseBegin :: Maybe Day
, ccCourseEnd :: Maybe Day
, ccCourseLang :: Maybe Lang -- maybe fix language to fit course content language
, ccParticipant :: UserDisplayName
, ccFraNumber :: Maybe Text
, ccFraDepartment :: Maybe Text
, ccCompany :: Maybe Text
}
deriving (Eq, Show)
instance MDLetter LetterCourseCertificate where
encrypPDFfor _ = NoPassword
getLetterKind _ = Plain
getLetterEnvelope _ = 'c'
getTemplate LetterCourseCertificate{ccCourseContent = Just ccc} =
Text.replace "%%%course-content%%%" (unlines ccc) $
decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md")
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md")
letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt =
mkMeta
[ toMeta "participant" ccParticipant
, mbMeta "fra-number" ccFraNumber
, mbMeta "fra-department" ccFraDepartment
, mbMeta "company" ccCompany
, toMeta "course-name" ccCourseName
, mbMeta "course-content" ccCourseContent
, mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin)
, mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd)
, toMeta "lang" (fromMaybe lang ccCourseLang)
]
getPJId LetterCourseCertificate{..} =
PrintJobIdentification
{ pjiName = "Certificate"
, pjiApcAcknowledge = "cc-" <> ccCourseName
, pjiRecipient = Nothing
, pjiSender = Nothing
, pjiCourse = Just ccCourseId
, pjiQualification = Nothing
, pjiLmsUser = Nothing
, pjiFileName = "cert_" <> ccCourseSchool <> "-" <> ccCourseShorthand <> "-" <> ccTutorialName
}
makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate)
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) = eq2nothing $ occurrencesBounds occurrences
forM participants $ \uid -> do
User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid
(ccFraNumber, ccFraDepartment, ccCompany) <-
if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber
then
return (userCompanyPersonalNumber, userCompanyDepartment, Nothing)
else do
usrComp <- selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyId]
comp <- forM usrComp (get . userCompanyCompany . entityVal)
let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible
return (Nothing, Nothing, res)
return LetterCourseCertificate{..}

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

@ -36,6 +36,8 @@ import Handler.Utils.DateTime
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
-- instance P.ToMetaValue (CI Text) where
-- toMetaValue = P.MetaString . CI.original
----------------------
-- Pandoc Functions --
@ -172,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)
@ -218,13 +221,12 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling
deriving (Eq, Show)
class MDLetter l where
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta
letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta -- formatter/lang for individual receiver, set Meta "lang" for individually translated letters
-- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetter for each receiver
getPJId :: l -> PrintJobIdentification
getLetterEnvelope :: l -> Char
getLetterKind :: Proxy l -> LetterKind
getTemplate :: Proxy l -> Text
getTemplate :: l -> Text
encrypPDFfor :: Proxy l -> EncryptPDFfor
letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
@ -233,9 +235,23 @@ 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"
getApcIdent :: P.Meta -> Maybe Text
getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t
getApcIdent _ = Nothing
getApcIdent _ = Nothing
----------------
-- Mail Class --
----------------
-- this is for letters that may alternatively be sent as attachments to emails
class MDMail l where --
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment

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

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -45,18 +45,20 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene
lmsUrl = "https://drive.fraport.de"
lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
lmsIdent = getLmsIdent lmsLogin
instance MDLetter LetterRenewQualificationF where
encrypPDFfor _ = PasswordUnderling
getLetterKind _ = PinLetter
getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
instance MDMail LetterRenewQualificationF where
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
instance MDLetter LetterRenewQualificationF where
encrypPDFfor _ = PasswordUnderling
getLetterKind _ = PinLetter
getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
isSupervised = rcvrId /= qualHolderID
in mkMeta $
@ -65,7 +67,8 @@ instance MDLetter LetterRenewQualificationF where
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
] <>
[ toMeta "login" lmsIdent
[ toMeta "lang" lang
, toMeta "login" lmsIdent
, toMeta "pin" lmsPin
, toMeta "examinee" qualHolderDN
, toMeta "expiry" (format SelFormatDate qualExpiry)
@ -83,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])
}

73
templates/letter/fraport_qualification.md
View File

@ -1,15 +1,84 @@
---
### Metaddaten, welche hier eingestellt werden:
# keine
### Metadaten, welche automatisch ersetzt werden:
lang: de-de
is-de: true
date: 11.11.1111
test1: this **is really** a test
test2: 'this **is another** test'
test3: |
<h1>First</h1>
<p>Here is some text with <em>emphasis</em> to see.
...
\renewcommand{\familydefault}{\sfdefault}
$if(is-de)$
\medskip
\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge}
\vspace{\fill}
# $participant$ {-}
$if(fra-number)$
## $fra-number$ $fra-department$ {-}
$endif$
$if(company)$
## $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$}}
der Fahrerausbildung der Fraport AG teilgenommen.
\vspace{\fill}
\vspace{\fill}
$if(course-content)$
## Inhalte: {-}
%%%course-content%%%
$endif$
\vspace{\fill}
\vspace{\fill}
Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt.
Dieses Zertifikat wurde maschinell erstellt.
\medskip
Frankfurt am Main, $date$
Fraport College
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
\vspace{\fill}
<!-- deutsche version -->
$else$
<!-- english version -->
<!-- english version -->
# Certificate of attendance
**English version is not yet implemened.**
TODO
$endif$
\clearpage

14
templates/letter/plain_article.latex
View File

@ -1,8 +1,9 @@
%Based upon https://github.com/benedictdudel/pandoc-letter-din5008
\documentclass[
paper=A4,
version=last,
firstfoot=false % first-page footer
]{scrlttr2}
]{scrartcl}
\PassOptionsToPackage{hyphens}{url}
\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref}
@ -56,8 +57,9 @@ $endif$
\usepackage{DejaVuSansMono} % better monofont
\else
% if luatex or xetex
\usepackage{fontspec}
\usepackage{fontspec}
\setmonofont{DejaVu Sans Mono}
%\renewcommand{\familydefault}{\sfdefault}
\fi
$if(mathspec)$
@ -84,9 +86,9 @@ $endif$
\usepackage{enumitem}
\setlength{\oddsidemargin}{\useplength{toaddrhpos}}
\addtolength{\oddsidemargin}{-1in}
\setlength{\textwidth}{\useplength{firstheadwidth}}
%\setlength{\oddsidemargin}{\useplength{toaddrhpos}}
%\addtolength{\oddsidemargin}{-1in}
%\setlength{\textwidth}{\useplength{firstheadwidth}}
\usepackage[absolute,quiet,overlay]{textpos}%,showboxes
\setlength{\TPHorizModule}{1mm}
@ -95,6 +97,8 @@ $endif$
\providecommand{\tightlist}{%
\setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}}
\pagestyle{empty}
\begin{document}%
$if(apc-ident)$
\begin{textblock}{200}(5,5)%hpos,vpos

10
test/Database/Fill.hs
View File

@ -942,11 +942,11 @@ fillDb = do
, courseTerm = tk
, courseSchool = avn
, courseCapacity = capacity
, courseVisibleFrom = jtt TermDayStart 0 Nothing toMidnight
, courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight
, courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
, courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
, courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, courseVisibleFrom = jtt TermDayStart 1 Nothing toMidnight
, courseVisibleTo = jtt TermDayEnd 10 Nothing beforeMidnight
, courseRegisterFrom = jtt TermDayLectureStart 0 Nothing toMidnight
, courseRegisterTo = jtt TermDayLectureStart 1 Nothing toMidnight
, courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight
, courseRegisterSecret = Nothing
, courseMaterialFree = True
}