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

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-03-27 15:13:20 +00:00
commit 18298e53a6
23 changed files with 321 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -43,7 +43,7 @@ StudySubTermsChildKey: Kind
StudySubTermsChildName: Kindname
MailTestFormEmail: E-Mail-Adresse
MailTestFormLanguages: Spracheinstellungen
MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}
MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet.
TestDownload: Download-Test
BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
BearerTokenAuthorityGroups: Token-Authorität (Gruppen)

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

@ -43,7 +43,7 @@ StudySubTermsChildKey: Child
StudySubTermsChildName: Child-Name
MailTestFormEmail: Email address
MailTestFormLanguages: Language settings
MailRerouteTo dev: All email will not be sent to the intended recipients, but rerouted to _{dev}
MailRerouteTo dev: All email will not be sent to the intended recipients, but rerouted to _{dev}. Printjobs are executed within FRADrive only, they are not sent for actual printing.
TestDownload: Download test
BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions into bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
BearerTokenAuthorityGroups: Authority (groups)

2
src/Auth/LDAP.hs
View File

@ -61,7 +61,7 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|]
] ++
[ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident'
| ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]]
| ident' <- [ident, [st|#{ident}@fraport.de|]]
, ldapUserEmail' <- toList ldapUserEmail
-- ] ++
-- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames"

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

@ -260,11 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
| otherwise
-> throwM CampusUserInvalidIdent
userEmail <- if -- TODO: refactor
-- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-- -> return $ CI.mk userEmail
| userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-> return $ CI.mk userEmail
-- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
-- -> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
@ -306,19 +306,20 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userPrefersPostal = userDefaultPrefersPostal
, ..
}
userUpdate = [
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserEmail =. userEmail
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
, UserCompanyDepartment =. userCompanyDepartment
] ++
[ UserLastAuthentication =. Just now | isLogin ]
userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++
[ UserEmail =. userEmail | validEmail' userEmail ] ++
[
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
, UserCompanyDepartment =. userCompanyDepartment
]
return (newUser, userUpdate)
where

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

@ -15,6 +15,7 @@ module Handler.Admin.Avs
import Import
import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.Aeson.Encode.Pretty as Pretty
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
@ -87,7 +88,7 @@ validateAvsQueryPerson = do
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
where
parseAvsIds :: Text -> AvsQueryStatus
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
@ -102,6 +103,25 @@ validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
makeAvsContactForm :: Maybe AvsQueryContact -> Form AvsQueryContact
makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
where
parseAvsIds :: Text -> AvsQueryContact
parseAvsIds txt = AvsQueryContact $ Set.fromList ids
where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys
unparseAvsIds :: AvsQueryContact -> Text
unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
validateAvsQueryContact = do
AvsQueryContact ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
avsLicenceOptions :: OptionList AvsLicence
avsLicenceOptions = mkOptionList
[ Option
@ -135,24 +155,42 @@ postAdminAvsR = do
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{tshow p}
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbPerson <- formResultMaybe presult procFormPerson
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
res <- avsQueryStatus fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{tshow p}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbStatus <- formResultMaybe sresult procFormStatus
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
let procFormContact fr = do
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
res <- avsQueryContact fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseContact pns) -> return $ Just [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
<li>
<ul>
<li>AvsId: #{tshow avsContactPersonID}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
|]
mbContact <- formResultMaybe cresult procFormContact
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
@ -259,11 +297,12 @@ postAdminAvsR = do
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
contactForm = wrapFormHere cwidget cenctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
@ -393,7 +432,7 @@ getProblemAvsSynchR = do
procRes aLic (LicenceTableChangeAvsData , apids) = do
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
let no_req = Set.size apids
mkind = if oks < no_req then Warning else Success
mkind = if oks < no_req || no_req < 0 then Warning else Success
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
redirect ProblemAvsSynchR -- reload to update all tables
@ -408,10 +447,10 @@ getProblemAvsSynchR = do
Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = licenceTableChangeFDriveReason
}
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
}
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
redirect ProblemAvsSynchR -- must be outside runDB
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
@ -420,7 +459,7 @@ getProblemAvsSynchR = do
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI Success $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
redirect ProblemAvsSynchR -- must be outside runDB
formResult tres2 $ procRes AvsLicenceRollfeld

2
src/Handler/Course/ParticipantInvite.hs
View File

@ -121,7 +121,7 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
postTAddUserR tid ssh csh (CI.mk $ tshow $ succ today) -- Don't use user date display setting, so that tutorial default names conform to all users
postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users
getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html

2
src/Handler/LMS.hs
View File

@ -385,7 +385,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin))

2
src/Handler/PrintCenter.hs
View File

@ -248,7 +248,7 @@ mkPJTable = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortDescBy "created"]
psValidator = def & defaultSorting [SortDescBy "acknowledged", SortDescBy "created"]
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
over _1 postprocess <$> dbTable psValidator DBTable{..}

7
src/Handler/Qualification.hs
View File

@ -312,10 +312,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, single $ sortUserEmail queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("blocked-due" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
-- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -380,6 +380,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed"
Just LmsExpired{} -> return $ Just "Expired"
Just LmsSuccess{} -> return $ Just "Success"
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
preview (resultLmsUser . _entityVal . _lmsUserStarted)
@ -462,7 +463,7 @@ postQualificationR sid qsh = do
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths))
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell' linkLmsUser) lu
]
psValidator = def & defaultSorting [SortDescBy "blocked-due", SortDescBy "valid-until"]
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent)

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

@ -130,12 +130,12 @@ postTUsersR tid ssh csh tutn = do
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
today <- utctDay <$> liftIO getCurrentTime
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers
addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserSendMailData{}, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]

18
src/Handler/Users.hs
View File

@ -132,7 +132,7 @@ postUsersR = do
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function ->
sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
@ -145,7 +145,7 @@ postUsersR = do
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
in listCell' getFunctions i18nCell
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
@ -201,7 +201,14 @@ postUsersR = do
, dbtRowKey = (E.^. UserId)
, dbtColonnade
, dbtProj = dbtProjId
, dbtSorting = Map.fromList
, dbtSorting = Map.fromList $
[ ( SortingKey $ CI.mk $ toPathPiece function
, SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId
E.&&. uf E.^. UserFunctionFunction E.==. E.val function
return (uf E.^. UserFunctionSchool)
) | function <- universeF
] ++
[ ( "name"
, SortColumn $ \user -> user E.^. UserSurname
)
@ -234,6 +241,11 @@ postUsersR = do
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr E.^. UserDisplayName)
)
, ( "system-function"
, SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId
return $ usf E.^. UserSystemFunctionFunction
)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
[ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->

8
src/Handler/Utils/LMS.hs
View File

@ -20,7 +20,7 @@ module Handler.Utils.LMS
, lmsDeletionDate
, lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr
, lmsUserStatusWidget
, lmsStatusIcon, lmsUserStatusWidget
, randomLMSIdent, randomLMSIdentBut
, randomLMSpw, maxLmsUserIdentRetries
) where
@ -164,12 +164,16 @@ randomLMSpw = randomText extra lengthPassword
where
extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
lmsStatusIcon :: LmsStatus -> Icon
lmsStatusIcon LmsSuccess{} = IconOK
lmsStatusIcon LmsExpired{} = IconExpired
lmsStatusIcon _other = IconNotOK
lmsUserStatusWidget :: LmsUser -> Widget
lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} =
[whamlet|$newline never
^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
\ ^{boolSymbol (isLmsSuccess lStat)}
\ ^{icon (lmsStatusIcon lStat)}
|]
lmsUserStatusWidget LmsUser{lmsUserStarted} =
[whamlet|$newline never

55
src/Handler/Utils/Mail.hs
View File

@ -52,6 +52,13 @@ userAddress :: User -> Address
userAddress User{userEmail, userDisplayEmail, userDisplayName}
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
userAddressError User{userEmail, userDisplayEmail, userDisplayName}
| Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
| otherwise = do
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " Sent to support instead." -- <> " with subject " <> tshow failedSubject
(True,) <$> getsYesod (view _appMailSupport)
-- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
userMailT :: ( MonadHandler m
, HandlerSite m ~ UniWorX
@ -59,7 +66,7 @@ userMailT :: ( MonadHandler m
, MonadUnliftIO m
) => UserId -> MailT m () -> m ()
userMailT uid mAct = do
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
let undername = underling ^. _userDisplayName -- nameHtml' underling
undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
@ -98,21 +105,17 @@ userMailT uid mAct = do
$else
_{MsgMailSupervisorNoCopy}
|]
mailtoAddr = userAddress supervisor
if validEmail $ addressEmail mailtoAddr
then
mailT ctx $ do
-- TODO: ensure that the Email is VALID HERE!
_mailTo .= pure mailtoAddr
mAct
if uid==svr
then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
else -- do
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
(mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise
mailT ctx $ do
_mailTo .= pure mailtoAddr
mAct
if uid==svr
then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
unless mailOk $ mapSubject ("[ERROR]" <>)
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
userMailTdirect :: ( MonadHandler m
@ -137,23 +140,13 @@ userMailTdirect uid mAct = do
SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions
}
mailtoAddr = userAddress user
(mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise
mailT ctx $ do
failedSubject <- lookupMailHeader "Subject"
unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
-- failedSubject <- lookupMailHeader "Subject"
-- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
_mailTo .= pure mailtoAddr
mAct
{- Problematic due to return type a
if validEmail $ addressEmail mailtoAddr
then mailT ctx $ do
_mailTo .= pure mailtoAddr
mAct
else
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
-}
unless mailOk $ mapSubject ("[ERROR]" <>)
mAct
addFileDB :: ( MonadMail m
, HandlerSite m ~ UniWorX

7
src/Handler/Utils/Table/Cells.hs
View File

@ -12,7 +12,7 @@ import Handler.Utils.Table.Pagination
import Handler.Utils.DateTime
import Handler.Utils.Widgets
import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget)
import Handler.Utils.LMS (lmsUserStatusWidget, lmsStatusIcon)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -347,10 +347,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
where
ic | isLmsSuccess ls = IconOK
| otherwise = IconNotOK
lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat

6
src/Handler/Utils/Table/Pagination.hs
View File

@ -163,6 +163,7 @@ data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValu
data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
| forall a. PersistField a => SortColumnNullsInv { getSortColumn :: t -> E.SqlExpr (E.Value a) }
| forall a. PersistField a => SortColumnNeverNull { getSortColumn :: t -> E.SqlExpr (E.Value a) }
| SortColumns { getSortColumns :: t -> [SomeExprValue] }
| SortProjected { sortProjected :: r' -> r' -> Ordering }
@ -182,10 +183,13 @@ sqlSortDirection (SortColumn e ) = Just $ \case
sqlSortDirection (SortColumnNullsInv e ) = Just $ \case
SortAsc -> pure . E.ascNullsFirst . e
SortDesc -> pure . E.descNullsLast . e
sqlSortDirection (SortColumnNeverNull e ) = Just $ \case
SortAsc -> pure . E.asc . e
SortDesc -> pure . E.descNullsLast . e
sqlSortDirection (SortColumns es) = Just $ \case
SortAsc -> fmap (\(SomeExprValue v) -> E.asc v) . es
SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
sqlSortDirection _ = Nothing
sqlSortDirection _ = Nothing
sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
sortDirectionProjected SortProjected{..} = sortProjected

9
src/Jobs.hs
View File

@ -246,10 +246,11 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
{ jobWorkers = jobWorkers oldState `Map.withoutKeys` Map.keysSet deadWorkers
}
guard . not $ Map.null deadWorkers
return . forM_ (Map.toList deadWorkers) $ \(jobAsync, result) -> do
case result of
Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
Left e -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
return . forM_ (Map.toList deadWorkers) $ \(jobAsync, _result) -> do
-- TOO MUCH LOGGING
-- case result of
-- Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
-- Left e -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
void . lift . allocateLinkedAsync $
let go = do
next <- evalRandTIO . mapRandT (liftIO . atomically) . runMaybeT $ do

27
src/Jobs/Handler/LMS.hs
View File

@ -77,6 +77,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. E.isNothing (luser E.^. LmsUserEnded)
)
pure quser
let usr_job :: Entity QualificationUser -> Job
@ -131,7 +132,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
(Just _) -> return () -- lmsUser started, but not yet notified
-- purge LmsIdent adter QualificationAuditDuration expired
-- purge LmsIdent after QualificationAuditDuration expired
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act
where
@ -140,19 +141,37 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
let qshort = CI.original $ qualificationShorthand quali
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime
let nowaday = utctDay now
-- end users that expired by doing nothing
expiredLearners <- E.select $ do
(quser :& luser) <- E.from $
E.table @QualificationUser
`E.innerJoin` E.table @LmsUser
`E.on` (\(quser :& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification nowaday quser)
pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)]
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
-- TODO: notify expired used
-- let nowaday = utctDay now
-- forM_ (E.unValue . snd <$> delusersVals) $ \uid ->
--
-- forM_ expiredLearners $ \uid ->
-- queueDBJob JobSendNotification
-- { jRecipient = uid
-- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
-- }
-- purge outdated LmsUsers
case qualificationAuditDuration quali of
Nothing -> return () -- no automatic removal
(Just auditDuration) -> do
let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
$logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration
$logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort
delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid

122
src/Model/Types/Avs.hs
View File

@ -249,7 +249,8 @@ instance ToJSON AvsLicence where
instance FromJSON AvsLicence where
parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case
| n == 2 = pure AvsLicenceRollfeld
| n == 0 = pure AvsNoLicence -- n==0 never received from AVS, only sent to AVS
| n == 0 = pure AvsNoLicence
-- | n ==(-1) = pure AvsNoLicenceGuest -- InfoContact may send -1 for Guest unable to obtain a licence
#ifdef DEVELOPMENT
parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
#else
@ -345,7 +346,7 @@ instance Canonical AvsDataPersonCard where
-- TODO: use canonical in FromJSON/ToJSON instances for consistency
instance FromJSON AvsDataPersonCard where
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard -- NOTE: String "AvsDataPersonCard" is only used in error messages when parsing fails
<$> ((v .: "Valid") <&> sloppyBool)
<*> v .:? "ValidTo"
<*> v .:? "IssueDate"
@ -401,7 +402,7 @@ data AvsDataPerson = AvsDataPerson
{ avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
, avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
, avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
, avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar
, avsPersonPersonNo :: Int -- AVS Personennummer, in menschlicher Kommunikation verwendet
, avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle!
, avsPersonPersonCards :: Set AvsDataPersonCard
}
@ -475,6 +476,108 @@ deriveJSON defaultOptions
, rejectUnknownFields = False
} ''AvsLicenceResponse
data AvsPersonInfo = AvsPersonInfo
{ avsInfoPersonNo :: Text -- Int -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation
, avsInfoFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
, avsInfoLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
, avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
, avsInfoDateOfBirth :: Maybe Day
, avsInfoPersonEMail :: Maybe Text
, avsInfoPersonMobilePhoneNo :: Maybe Text
, avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
} deriving (Eq, Ord, Show, Generic)
makeLenses_ ''AvsPersonInfo
instance FromJSON AvsPersonInfo where
parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo
<$> o .: "PersonsNo" -- NOTE: PersonsNo, not PersonNo as elsewhere
<*> o .: "FirstName"
<*> o .: "LastName"
<*> o .: "RampLicence"
<*> o .:? "DateOfBirth"
<*> o .:?! "PersonEMail"
<*> o .:?! "PersonMobilePhoneNo"
<*> o .:?! "InternalPersonalNo"
instance ToJSON AvsPersonInfo where
toJSON AvsPersonInfo{..} = object $ catMaybes
[ ("DateOfBirth" .=) <$> avsInfoDateOfBirth
, ("PersonEMail" .=) <$> avsInfoPersonEMail & canonical
, ("PersonMobilePhoneNo" .=) <$> avsInfoPersonMobilePhoneNo & canonical
, ("InternalPersonalNo" .=) <$> avsInfoInternalPersonalNo & canonical
] <>
[ "PersonsNo" .= avsInfoPersonNo
, "FirstName" .= avsInfoFirstName
, "LastName" .= avsInfoLastName
, "RampLicence" .= avsInfoRampLicence
]
-- derivePersistFieldJSON ''AvsPersonInfo
data AvsFirmInfo = AvsFirmInfo
{ avsFirmFirm :: Text
, avsFirmFirmNo :: Int
, avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen!
, avsFirmZIPCode :: Maybe Text
, avsFirmCity :: Maybe Text
, avsFirmCountry :: Maybe Text
, avsFirmStreetANDHouseNo :: Maybe Text
, avsFirmEMail :: Maybe Text
, avsFirmEMailSuperior :: Maybe Text
} deriving (Eq, Ord, Show, Generic)
makeLenses_ ''AvsFirmInfo
instance FromJSON AvsFirmInfo where
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
<$> o .: "Firm"
<*> o .: "FirmNo"
<*> o .: "Abbreviation"
<*> o .:?! "ZIPCode"
<*> o .:?! "City"
<*> o .:?! "Country"
<*> o .:?! "StreetANDHouseNo"
<*> o .:?! "EMail"
<*> o .:?! "EMailSuperior"
instance ToJSON AvsFirmInfo where
toJSON AvsFirmInfo{..} = object $ catMaybes
[ ("ZIPCode" .=) <$> avsFirmZIPCode & canonical
, ("City" .=) <$> avsFirmCity & canonical
, ("Country" .=) <$> avsFirmCountry & canonical
, ("StreetANDHouseNo" .=) <$> avsFirmStreetANDHouseNo & canonical
, ("EMail" .=) <$> avsFirmEMail & canonical
, ("EMailSuperior" .=) <$> avsFirmEMailSuperior & canonical
] <>
[ "Firm" .= avsFirmFirm
, "FirmNo" .= avsFirmFirmNo
, "Abbreviation" .= avsFirmAbbreviation
]
-- derivePersistFieldJSON ''AvsFirmInfo
data AvsDataContact = AvsDataContact
{ avsContactPersonID :: AvsPersonId
, avsContactPersonInfo :: AvsPersonInfo
, avsContactFirmInfo :: AvsFirmInfo
} deriving (Eq, Ord, Show, Generic)
makeLenses_ ''AvsDataContact
-- instance Canonical AvsDataContact where
-- canonical = over _avsContactPersonInfo canonical
-- . over _avsContactFirmInfo canonical
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2
, tagSingleConstructors = False
, rejectUnknownFields = False
} ''AvsDataContact
--------------
-- Responses --
@ -498,6 +601,15 @@ deriveJSON defaultOptions
, rejectUnknownFields = False
} ''AvsResponsePerson
newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2
, omitNothingFields = True
, tagSingleConstructors = False
, rejectUnknownFields = False
} ''AvsResponseContact
newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions
@ -548,6 +660,10 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryContact
newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryGetLicences

10
src/Model/Types/Lms.hs
View File

@ -34,7 +34,8 @@ deriveJSON defaultOptions
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-- ...also see similar type QualificationBlocked
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
| LmsExpired { lmsStatusDay :: Day }
| LmsSuccess { lmsStatusDay :: Day }
deriving (Eq, Read, Show, Generic, NFData)
@ -43,7 +44,11 @@ instance Ord LmsStatus where
| daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
, daycmp /= EQ = daycmp
compare LmsSuccess{} LmsBlocked{} = GT
compare LmsBlocked{} LmsSuccess{} = LT
compare LmsSuccess{} LmsExpired{} = GT
compare LmsBlocked{} LmsSuccess{} = LT
compare LmsExpired{} LmsSuccess{} = LT
compare LmsBlocked{} LmsExpired{} = GT
compare LmsExpired{} LmsBlocked{} = LT
compare _ _ = EQ
isLmsSuccess :: LmsStatus -> Bool
@ -66,6 +71,7 @@ derivePersistFieldJSON ''LmsStatus
instance Csv.ToField LmsStatus where
toField (LmsBlocked d) = "Failure: " <> Csv.toField d
toField (LmsExpired d) = "Expired: " <> Csv.toField d
toField (LmsSuccess d) = "Success: " <> Csv.toField d
data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day

20
src/Utils/Avs.hs
View File

@ -24,11 +24,12 @@ import Model.Types.Avs
-------------
-- AVS API --
-------------
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
type AVSPersonContact = "InfoPersonContact" :> ReqBody '[JSON] AvsQueryContact :> Post '[JSON] AvsResponseContact
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS
@ -49,6 +50,7 @@ data AvsQuery where
data AvsQuery = AvsQuery
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
, avsQueryContact :: forall m. MonadIO m => AvsQueryContact -> m (Either ClientError AvsResponseContact)
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
-- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
@ -66,6 +68,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
, avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "AVSNO:123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
}
@ -73,12 +76,17 @@ mkAvsQuery _ _ _ = AvsQuery
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
}
where
(rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = client avsApi basicAuth
( rawQueryPerson
:<|> rawQueryStatus
:<|> rawQueryContact
:<|> rawQueryGetLicences
:<|> rawQuerySetLicences ) = client avsApi basicAuth
catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!

1
src/Utils/Form.hs
View File

@ -301,6 +301,7 @@ data FormIdentifier
| FIDLmsLetter
| FIDAvsQueryPerson
| FIDAvsQueryStatus
| FIDAvsQueryContact
| FIDAvsCreateUser
| FIDAvsQueryLicenceDiffs
| FIDAvsQueryLicence

2
src/Utils/Icon.hs
View File

@ -107,6 +107,7 @@ data Icon
| IconAt
| IconSupervisor
| IconWaitingForUser
| IconExpired
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -192,6 +193,7 @@ iconText = \case
IconAt -> "at"
IconSupervisor -> "head-side" -- must be notably different to user
IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon

14
templates/avs.hamlet
View File

@ -38,7 +38,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
Person search:
Person Search:
^{personForm}
$maybe answer <- mbPerson
<p>
@ -47,12 +47,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
Person status:
Person Status:
^{statusForm}
$maybe answer <- mbStatus
<p>
Unverarbeitete Antwort: #
^{answer}
<section>
<p>
Info Person Contact:
^{contactForm}
$maybe answer <- mbContact
<p>
Unverarbeitete Antwort: #
^{answer}
<section>
^{modal "AVS Konfiguration" (Right avsWgt)}