feat: external exam csv import & ldap lookup during csv import
This commit is contained in:
Gregor Kleen
parent
2b153c1863
commit
1d14b6a69c
@ -717,6 +717,7 @@ LoginNecessary: Bitte melden Sie sich dazu vorher an!
|
||||
|
||||
InternalLdapError: Interner Fehler beim Campus-Login
|
||||
|
||||
CampusUserInvalidIdent: Konnte anhand des Campus-Logins keine eindeutige Identifikation
|
||||
CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln
|
||||
CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln
|
||||
CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln
|
||||
@ -1261,6 +1262,8 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen
|
||||
BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer
|
||||
|
||||
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
|
||||
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
|
||||
ExternalExamUsers coursen@CourseName examn@ExamName: Teilnehmer: #{coursen}, #{examn}
|
||||
|
||||
TitleMetrics: Metriken
|
||||
|
||||
@ -1674,10 +1677,16 @@ ExamUserSyncTime: Zeitpunkt
|
||||
ExamUserSyncSchools: Institute
|
||||
ExamUserSyncLastChange: Zuletzt geändert
|
||||
ExamUserMarkSynchronised: Prüfungsleistung als synchronisiert markieren
|
||||
ExternalExamUserMarkSynchronised: Prüfungsleistung als synchronisiert markieren
|
||||
ExternalExamUserMarkSynchronisedTip: Sollen beim CSV-Export automatisch alle heruntergeladenen Prüfungsleistungen als synchronisiert markiert werden? Diese Markierung dient als Hinweis an andere Prüfungsbeauftragte und die Kursverwalter, dass die Leistung an der korrekten Stelle vermerkt wurde und keiner weiteren Handlung bedarf.
|
||||
|
||||
ExamUserMarkSynchronisedCsv: Prüfungsleistungen beim Export als synchronisiert markieren
|
||||
ExamUserMarkSynchronisedCsvTip: Sollen beim CSV-Export automatisch alle heruntergeladenen Prüfungsleistungen als synchronisiert markiert werden? Diese Markierung dient als Hinweis an andere Prüfungsbeauftragte und die Kursverwalter, dass die Leistung an der korrekten Stelle vermerkt wurde und keiner weiteren Handlung bedarf.
|
||||
ExamUserMarkedSynchronised n@Int: #{n} #{pluralDE n "Prüfungsleistung" "Prüfungsleistungen"} als synchronisiert markiert
|
||||
|
||||
ExternalExamUserMarkSynchronisedCsv: Prüfungsleistungen beim Export als synchronisiert markieren
|
||||
ExternalExamUserMarkedSynchronised n@Int: #{n} #{pluralDE n "Prüfungsleistung" "Prüfungsleistungen"} als synchronisiert markiert
|
||||
|
||||
ExamOfficeExamUsersHeading: Prüfungsleistungen
|
||||
|
||||
ActionsHead: Aktionen
|
||||
@ -1780,6 +1789,11 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
|
||||
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
||||
|
||||
ExternalExamUserCsvRegister: Prüfungsleistung hinterlegen
|
||||
ExternalExamUserCsvSetTime: Zeitpunkt anpassen
|
||||
ExternalExamUserCsvSetResult: Ergebnis anpassen
|
||||
ExternalExamUserCsvDeregister: Hinterlegte Prüfungsleistung löschen
|
||||
|
||||
CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern
|
||||
CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen
|
||||
CourseApplicationsTableCsvSetRating: Bewertung eintragen
|
||||
|
||||
@ -169,6 +169,15 @@ data Transaction
|
||||
, transactionEmail :: UserEmail
|
||||
}
|
||||
|
||||
| TransactionExternalExamResultEdit
|
||||
{ transactionExternalExam :: ExternalExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionExternalExamResultDelete
|
||||
{ transactionExternalExam :: ExternalExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
|
||||
@ -3,6 +3,7 @@ module Auth.LDAP
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser, campusUser'
|
||||
, campusUserMatr, campusUserMatr'
|
||||
, CampusMessage(..)
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||
@ -43,7 +44,7 @@ data CampusMessage = MsgCampusIdentPlaceholder
|
||||
|
||||
|
||||
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
|
||||
findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
||||
@ -54,14 +55,24 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
||||
, ldapUserEmail' <- toList ldapUserEmail
|
||||
] ++
|
||||
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
|
||||
]
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
|
||||
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
[ ldapUserMatriculation Ldap.:= Text.encodeUtf8 userMatr
|
||||
]
|
||||
|
||||
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
|
||||
userSearchSettings LdapConf{..} = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
@ -99,13 +110,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present ldapUserPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
@ -123,6 +128,26 @@ campusUser' conf pool User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
|
||||
campusUserMatr :: MonadUnliftIO m => LdapConf -> LdapPool -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- findUserMatr conf ldap userMatr []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' conf pool
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
|
||||
|
||||
|
||||
|
||||
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) CampusMessage
|
||||
, MonadHandler m
|
||||
|
||||
@ -23,7 +23,7 @@ import Auth.Dummy
|
||||
import qualified Network.Wai as W (pathInfo)
|
||||
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
import Data.CaseInsensitive (original, mk)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (Digest, SHAKE256, SHAKE128)
|
||||
@ -45,6 +45,7 @@ import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import Data.List (nubBy, (!!), findIndex, inits)
|
||||
import qualified Data.List as List
|
||||
@ -1781,7 +1782,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
||||
School{..} <- MaybeT . runDB $ get ssh
|
||||
return (original schoolName, Just SchoolListR)
|
||||
return (CI.original schoolName, Just SchoolListR)
|
||||
breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR
|
||||
|
||||
breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing
|
||||
@ -1821,13 +1822,13 @@ instance YesodBreadcrumbs UniWorX where
|
||||
guardM . lift . runDB $
|
||||
(&&) <$> fmap isJust (get ssh)
|
||||
<*> fmap isJust (get tid)
|
||||
return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just HomeR
|
||||
breadcrumb (AllocationR tid ssh ash AShowR) = maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
breadcrumb (AllocationR tid ssh ash ARegisterR) = i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
|
||||
breadcrumb (AllocationR tid ssh ash (AApplyR cID)) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
||||
cid <- decrypt cID
|
||||
@ -1835,13 +1836,13 @@ instance YesodBreadcrumbs UniWorX where
|
||||
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
||||
guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
|
||||
MaybeT $ get cid
|
||||
return (original courseName, Just $ AllocationR tid ssh ash AShowR)
|
||||
return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
|
||||
|
||||
breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing
|
||||
breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR
|
||||
breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
|
||||
guardM . lift . runDB . existsBy $ TermSchoolCourseShort tid ssh csh
|
||||
return (original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
|
||||
breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
|
||||
@ -1899,7 +1900,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
|
||||
EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
|
||||
guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
|
||||
return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
|
||||
EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
|
||||
EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR
|
||||
@ -1912,7 +1913,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
|
||||
TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
|
||||
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
|
||||
return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||
TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||
TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||
@ -1922,7 +1923,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
|
||||
SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
|
||||
guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
|
||||
return (original shn, Just $ CourseR tid ssh csh SheetListR)
|
||||
return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
|
||||
SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR
|
||||
@ -1955,7 +1956,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
|
||||
MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
|
||||
guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
|
||||
return (original mnm, Just $ CourseR tid ssh csh MaterialListR)
|
||||
return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
|
||||
MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
|
||||
MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
|
||||
MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
|
||||
@ -2688,8 +2689,8 @@ pageActions (CourseR tid ssh csh SheetListR) =
|
||||
, menuItemLabel = MsgMenuCorrectionsOwn
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
|
||||
, ("corrections-school", original $ unSchoolKey ssh)
|
||||
, ("corrections-course", original csh)
|
||||
, ("corrections-school", CI.original $ unSchoolKey ssh)
|
||||
, ("corrections-course", CI.original csh)
|
||||
])
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = do
|
||||
@ -2915,9 +2916,9 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
|
||||
, menuItemLabel = MsgMenuCorrectionsOwn
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
|
||||
, ("corrections-school", original $ unSchoolKey ssh)
|
||||
, ("corrections-course", original csh)
|
||||
, ("corrections-sheet" , original shn)
|
||||
, ("corrections-school", CI.original $ unSchoolKey ssh)
|
||||
, ("corrections-course", CI.original csh)
|
||||
, ("corrections-sheet" , CI.original shn)
|
||||
])
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
|
||||
@ -3324,7 +3325,7 @@ routeNormalizers =
|
||||
|
||||
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) ()
|
||||
caseChanged a b
|
||||
| ((/=) `on` original) a b = do
|
||||
| ((/=) `on` CI.original) a b = do
|
||||
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
@ -3416,7 +3417,8 @@ instance YesodPersistRunner UniWorX where
|
||||
return . (, cleanup) $ DBRunner (\act -> $logDebugS "YesodPersist" "runDBRunner" >> runDBRunner act)
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidEmail
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
| CampusUserInvalidDisplayName
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
@ -3430,12 +3432,36 @@ instance Exception CampusUserConversionException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
|
||||
upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User)
|
||||
upsertCampusUser ldapData Creds{..} = do
|
||||
data UpsertCampusUserMode
|
||||
= UpsertCampusUser
|
||||
| UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
|
||||
| UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
makeLenses_ ''UpsertCampusUserMode
|
||||
makePrisms ''UpsertCampusUserMode
|
||||
|
||||
_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
|
||||
_upsertCampusUserMode mMode cs@Creds{..}
|
||||
| credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
|
||||
| credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
|
||||
| otherwise = setMode <$> mMode UpsertCampusUser
|
||||
where
|
||||
setMode UpsertCampusUser
|
||||
= cs{ credsPlugin = "LDAP" }
|
||||
setMode (UpsertCampusUserDummy ident)
|
||||
= cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
|
||||
setMode (UpsertCampusUserOther ident)
|
||||
= cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
|
||||
|
||||
others = "PWHash" :| []
|
||||
|
||||
upsertCampusUser :: UpsertCampusUserMode -> Ldap.AttrList [] -> DB (Entity User)
|
||||
upsertCampusUser plugin ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
||||
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
||||
userEmail' = fold $ do
|
||||
k' <- toList ldapUserEmail
|
||||
@ -3449,13 +3475,23 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ]
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| is _UpsertCampusUserOther plugin
|
||||
= error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (not isDummy)
|
||||
userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- userIdent''
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- plugin ^? _upsertCampusUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
|
||||
-> return $ mk userEmail
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName' <- if
|
||||
@ -3505,8 +3541,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userIdent = mk credsIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
@ -3534,9 +3569,9 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
, UserSex =. userSex
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | not isDummy ]
|
||||
[ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
|
||||
|
||||
user@(Entity userId userRec) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate
|
||||
user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
|
||||
@ -3549,7 +3584,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` mk) $ do
|
||||
termNames = nubBy ((==) `on` CI.mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserFieldName
|
||||
v' <- v
|
||||
@ -3620,7 +3655,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
| otherwise -> do
|
||||
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
|
||||
assimilateSubTerms subterms unusedFeats
|
||||
$logDebugS "Campus" [st|Terms for “#{credsIdent}”: #{tshow (sts, fs')}|]
|
||||
$logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
|
||||
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
||||
|
||||
let
|
||||
@ -3726,8 +3761,6 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
associateUserSchoolsByTerms :: UserId -> DB ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
@ -3803,18 +3836,18 @@ instance YesodAuth UniWorX where
|
||||
setTitleI MsgLoginTitle
|
||||
$(widgetFile "login")
|
||||
|
||||
authenticate Creds{..} = liftHandler . runDB $ do
|
||||
authenticate creds@Creds{..} = liftHandler . runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
userIdent = mk credsIdent
|
||||
uAuth = UniqueAuthentication userIdent
|
||||
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
||||
upsertMode = creds ^? _upsertCampusUserMode
|
||||
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
|
||||
isOther = is (_Just . _UpsertCampusUserOther) upsertMode
|
||||
|
||||
excRecovery res
|
||||
| isDummy || isPWHash
|
||||
| isDummy || isOther
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
@ -3858,12 +3891,12 @@ instance YesodAuth UniWorX where
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
|
||||
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) -> do
|
||||
let userCreds = Creds credsPlugin (original userIdent) credsExtra
|
||||
ldapData <- campusUser ldapConf ldapPool userCreds
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
|
||||
Nothing
|
||||
Just (ldapConf, ldapPool)
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapConf ldapPool Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
|
||||
@ -8,6 +8,7 @@ import Import hiding ((<.), (.>))
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Csv
|
||||
|
||||
import Handler.ExamOffice.Exam (examCloseWidget)
|
||||
@ -372,7 +373,7 @@ data ExamUserCsvAction
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
|
||||
, fieldLabelModifier = camelToPathPiece' 3
|
||||
, fieldLabelModifier = camelToPathPiece' 4
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''ExamUserCsvAction
|
||||
|
||||
@ -624,7 +625,7 @@ postEUsersR tid ssh csh examn = do
|
||||
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
uid <- lift $ view _2 <$> guessUser csv
|
||||
uid <- lift $ view _2 <$> guessUser' csv
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
|
||||
, dbtCsvComputeActions = \case
|
||||
DBCsvDiffMissing{dbCsvOldKey}
|
||||
@ -632,7 +633,7 @@ postEUsersR tid ssh csh examn = do
|
||||
DBCsvDiffNew{dbCsvNewKey = Just _}
|
||||
-> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
(isPart, uid) <- lift $ guessUser dbCsvNew
|
||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
@ -930,37 +931,17 @@ postEUsersR tid ssh csh examn = do
|
||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
Entity _ User{..} = view resultUser $ existing ! registration
|
||||
|
||||
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
|
||||
users <- E.select . E.from $ \user -> do
|
||||
E.where_ . E.or $ catMaybes
|
||||
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
|
||||
, (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName
|
||||
, (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname
|
||||
, (user E.^. UserFirstName `E.hasInfix`) . E.val <$> csvEUserFirstName
|
||||
]
|
||||
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
return (isCourseParticipant, user)
|
||||
let users' = reverse $ sortBy closeness users
|
||||
closeness :: (E.Value Bool, Entity User) -> (E.Value Bool, Entity User) -> Ordering
|
||||
closeness = mconcat $ catMaybes
|
||||
[ pure $ comparing (preview $ _2 . _entityVal . _userMatrikelnummer . only csvEUserMatriculation)
|
||||
, pure $ comparing (view _1)
|
||||
, csvEUserSurname <&> \surn -> comparing (preview $ _2 . _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
|
||||
, csvEUserFirstName <&> \firstn -> comparing (preview $ _2 . _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
|
||||
, csvEUserName <&> \dispn -> comparing (preview $ _2 . _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
|
||||
|
||||
guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser' ExamUserTableCsv{..} = do
|
||||
let criteria = Set.fromList $ catMaybes
|
||||
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
|
||||
, GuessUserDisplayName <$> csvEUserName
|
||||
, GuessUserSurname <$> csvEUserSurname
|
||||
, GuessUserFirstName <$> csvEUserFirstName
|
||||
]
|
||||
case users' of
|
||||
[(E.Value isPart, Entity uid _)]
|
||||
-> return (isPart, uid)
|
||||
(x@(E.Value isPart, Entity uid _) : x' : _)
|
||||
| GT <- x `closeness` x'
|
||||
-> return (isPart, uid)
|
||||
_other
|
||||
-> throwM ExamUserCsvExceptionNoMatchingUser
|
||||
pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
|
||||
(,) <$> existsBy (UniqueParticipant pid examCourse) <*> pure pid
|
||||
|
||||
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
|
||||
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
|
||||
@ -971,7 +952,7 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
||||
uid <- view _2 <$> guessUser csv
|
||||
uid <- view _2 <$> guessUser' csv
|
||||
oldFeatures <- getBy $ UniqueParticipant uid examCourse
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||
|
||||
@ -140,15 +140,15 @@ resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname
|
||||
resultSynchronised = _dbrOutput . _9 . traverse
|
||||
|
||||
data ExamUserTableCsv = ExamUserTableCsv
|
||||
{ csvEUserSurname :: Text
|
||||
, csvEUserFirstName :: Text
|
||||
, csvEUserName :: Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserField :: Maybe Text
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
{ csvEUserSurname :: Text
|
||||
, csvEUserFirstName :: Text
|
||||
, csvEUserName :: Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserField :: Maybe Text
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
, csvEUserOccurrenceStart :: Maybe ZonedTime
|
||||
, csvEUserExamResult :: ExamResultPassedGrade
|
||||
, csvEUserExamResult :: ExamResultPassedGrade
|
||||
}
|
||||
deriving (Generic)
|
||||
makeLenses_ ''ExamUserTableCsv
|
||||
@ -396,7 +396,7 @@ postEGradesR tid ssh csh examn = do
|
||||
dbtIdent = "exam-results"
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = ExamUserCsvExportData
|
||||
<$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv) (Just True)
|
||||
<$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv & setTooltip MsgExamUserMarkSynchronisedCsvTip) (Just False)
|
||||
, dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do
|
||||
when csvEUserMarkSynchronised $ markSynced k
|
||||
return $ ExamUserTableCsv
|
||||
|
||||
@ -4,7 +4,15 @@ module Handler.ExamOffice.ExternalExam
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
import Handler.Utils.ExternalExam.Users
|
||||
|
||||
getEEGradesR, postEEGradesR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
|
||||
getEEGradesR = postEEGradesR
|
||||
postEEGradesR = error "Not implemented"
|
||||
postEEGradesR tid ssh coursen examn = do
|
||||
(_, table) <- runDB $ do
|
||||
eExam <- getBy404 $ UniqueExternalExam tid ssh coursen examn
|
||||
makeExternalExamUsersTable EEUMGrades eExam
|
||||
|
||||
siteLayoutMsg (MsgExternalExamGrades coursen examn) $ do
|
||||
setTitleI MsgBreadcrumbExternalExamGrades
|
||||
table
|
||||
|
||||
@ -4,7 +4,15 @@ module Handler.ExternalExam.Users
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.ExternalExam.Users
|
||||
|
||||
getEEUsersR, postEEUsersR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
|
||||
getEEUsersR = postEEUsersR
|
||||
postEEUsersR = error "Not implemented"
|
||||
postEEUsersR tid ssh coursen examn = do
|
||||
(_, table) <- runDB $ do
|
||||
eExam <- getBy404 $ UniqueExternalExam tid ssh coursen examn
|
||||
makeExternalExamUsersTable EEUMUsers eExam
|
||||
|
||||
siteLayoutMsg (MsgExternalExamUsers coursen examn) $ do
|
||||
setTitleI MsgBreadcrumbExternalExamUsers
|
||||
table
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Utils.ExamOffice.ExternalExam
|
||||
( examOfficeExternalExamResultAuth
|
||||
( resultIsSynced
|
||||
, examOfficeExternalExamResultAuth
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -7,6 +8,27 @@ import Import.NoFoundation
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office
|
||||
-> E.SqlExpr (Entity ExternalExamResult)
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ hasSchool E.&&. anySync)
|
||||
where
|
||||
anySync = E.exists . E.from $ \synced ->
|
||||
E.where_ $ synced E.^. ExamOfficeExternalResultSyncedResult E.==. eexamResult E.^. ExternalExamResultId
|
||||
E.&&. synced E.^. ExamOfficeExternalResultSyncedTime E.>=. eexamResult E.^. ExternalExamResultLastChanged
|
||||
|
||||
hasSchool = E.exists . E.from $ \userFunction ->
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
|
||||
allSchools = E.not_ . E.exists . E.from $ \userFunction -> do
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
|
||||
E.where_ . E.not_ . E.exists . E.from $ \synced ->
|
||||
E.where_ $ synced E.^. ExamOfficeExternalResultSyncedSchool E.==. E.just (userFunction E.^. UserFunctionSchool)
|
||||
E.&&. synced E.^. ExamOfficeExternalResultSyncedResult E.==. eexamResult E.^. ExternalExamResultId
|
||||
E.&&. synced E.^. ExamOfficeExternalResultSyncedTime E.>=. eexamResult E.^. ExternalExamResultLastChanged
|
||||
|
||||
|
||||
examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
|
||||
-> E.SqlExpr (Entity ExternalExamResult)
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
|
||||
430
src/Handler/Utils/ExternalExam/Users.hs
Normal file
430
src/Handler/Utils/ExternalExam/Users.hs
Normal file
@ -0,0 +1,430 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Utils.ExternalExam.Users where
|
||||
|
||||
import Import hiding ((.:))
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Csv
|
||||
import Handler.Utils.Users
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Colonnade
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Data.Csv ((.:))
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
data ExternalExamUserMode = EEUMUsers | EEUMGrades
|
||||
deriving (Eq, Ord, Read, Show, Bounded, Enum, Generic, Typeable)
|
||||
instance Universe ExternalExamUserMode
|
||||
instance Finite ExternalExamUserMode
|
||||
nullaryPathPiece ''ExternalExamUserMode $ camelToPathPiece' 1
|
||||
|
||||
|
||||
type ExternalExamUserTableExpr = E.SqlExpr (Entity ExternalExamResult)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
|
||||
type ExternalExamUserTableData = DBRow ( Entity ExternalExamResult
|
||||
, Entity User
|
||||
, Bool
|
||||
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
||||
)
|
||||
|
||||
queryUser :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $(E.sqlIJproj 2 2)
|
||||
|
||||
queryResult :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity ExternalExamResult))
|
||||
queryResult = to $(E.sqlIJproj 2 1)
|
||||
|
||||
queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExternalExamUserTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryIsSynced authId = to $ ExternalExam.resultIsSynced authId <$> view queryResult
|
||||
|
||||
resultUser :: Lens' ExternalExamUserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultResult :: Lens' ExternalExamUserTableData (Entity ExternalExamResult)
|
||||
resultResult = _dbrOutput . _1
|
||||
|
||||
resultIsSynced :: Lens' ExternalExamUserTableData Bool
|
||||
resultIsSynced = _dbrOutput . _3
|
||||
|
||||
resultSynchronised :: Traversal' ExternalExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
|
||||
resultSynchronised = _dbrOutput . _4 . traverse
|
||||
|
||||
|
||||
data ExternalExamUserTableCsv = ExternalExamUserTableCsv
|
||||
{ csvEUserSurname :: Maybe Text
|
||||
, csvEUserFirstName :: Maybe Text
|
||||
, csvEUserName :: Maybe Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserOccurrenceStart :: ZonedTime
|
||||
, csvEUserExamResult :: ExamResultPassedGrade
|
||||
} deriving (Generic)
|
||||
makeLenses_ ''ExternalExamUserTableCsv
|
||||
|
||||
externalExamUserTableCsvOptions :: Csv.Options
|
||||
externalExamUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToNamedRecord ExternalExamUserTableCsv where
|
||||
toNamedRecord = Csv.genericToNamedRecord externalExamUserTableCsvOptions
|
||||
|
||||
instance DefaultOrdered ExternalExamUserTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder externalExamUserTableCsvOptions
|
||||
|
||||
instance FromNamedRecord ExternalExamUserTableCsv where
|
||||
parseNamedRecord csv
|
||||
= ExternalExamUserTableCsv
|
||||
<$> csv .:?? "surname"
|
||||
<*> csv .:?? "first-name"
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .: "occurrence-start"
|
||||
<*> csv .: "exam-result"
|
||||
|
||||
|
||||
instance CsvColumnsExplained ExternalExamUserTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations externalExamUserTableCsvOptions $ Map.fromList
|
||||
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
|
||||
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
||||
, ('csvEUserName , MsgCsvColumnExamUserName )
|
||||
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
||||
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
|
||||
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
||||
]
|
||||
|
||||
data ExternalExamUserAction
|
||||
= ExternalExamUserMarkSynchronised
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ExternalExamUserAction
|
||||
instance Finite ExternalExamUserAction
|
||||
nullaryPathPiece ''ExternalExamUserAction $ camelToPathPiece' 3
|
||||
embedRenderMessage ''UniWorX ''ExternalExamUserAction id
|
||||
|
||||
data ExternalExamUserActionData
|
||||
= ExternalExamUserMarkSynchronisedData
|
||||
|
||||
newtype ExternalExamUserCsvExportDataGrades = ExternalExamUserCsvExportDataGrades
|
||||
{ csvEEUserMarkSynchronised :: Bool
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
data ExamUserCsvException
|
||||
= ExamUserCsvExceptionNoMatchingUser
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception ExamUserCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
||||
|
||||
|
||||
data ExternalExamUserCsvActionClass
|
||||
= ExternalExamUserCsvRegister
|
||||
| ExternalExamUserCsvDeregister
|
||||
| ExternalExamUserCsvSetTime
|
||||
| ExternalExamUserCsvSetResult
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''ExternalExamUserCsvActionClass id
|
||||
|
||||
data ExternalExamUserCsvAction
|
||||
= ExternalExamUserCsvRegisterData
|
||||
{ externalExamUserCsvActUser :: UserId
|
||||
, externalExamUserCsvActTime :: UTCTime
|
||||
, externalExamUserCsvActResult :: ExamResultPassedGrade
|
||||
}
|
||||
| ExternalExamUserCsvSetTimeData
|
||||
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
||||
, externalExamUserCsvActTime :: UTCTime
|
||||
}
|
||||
| ExternalExamUserCsvSetResultData
|
||||
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
||||
, externalExamUserCsvActResult :: ExamResultPassedGrade
|
||||
}
|
||||
| ExternalExamUserCsvDeregisterData
|
||||
{ externalExamUserCsvActRegistration :: ExternalExamResultId
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
|
||||
, fieldLabelModifier = camelToPathPiece' 5
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''ExternalExamUserCsvAction
|
||||
|
||||
|
||||
makeExternalExamUsersTable :: ExternalExamUserMode
|
||||
-> Entity ExternalExam
|
||||
-> DB (FormResult (ExternalExamUserActionData, Set ExternalExamResultId), Widget)
|
||||
makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
let tid = externalExamTerm
|
||||
ssh = externalExamSchool
|
||||
coursen = externalExamCourseName
|
||||
examn = externalExamExamName
|
||||
|
||||
uid <- requireAuthId
|
||||
isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR
|
||||
currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
let
|
||||
resultView :: ExamResultGrade -> ExamResultPassedGrade
|
||||
resultView = fmap $ bool (Left . view passingGrade) Right externalExamShowGrades
|
||||
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
result <- view queryResult
|
||||
user <- view queryUser
|
||||
isSynced <- view . queryIsSynced $ E.val uid
|
||||
|
||||
lift $ do
|
||||
E.on $ result E.^. ExternalExamResultUser E.==. user E.^. UserId
|
||||
|
||||
E.where_ $ result E.^. ExternalExamResultExam E.==. E.val eeId
|
||||
|
||||
unless (isLecturer || mode == EEUMUsers) $ do
|
||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth (E.val uid) result
|
||||
|
||||
return (result, user, isSynced)
|
||||
dbtRowKey = views queryResult (E.^. ExternalExamResultId)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExternalExamUserTableData
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
||||
(,,,)
|
||||
<$> view _1 <*> view _2 <*> view (_3 . _Value)
|
||||
<*> getSynchronised
|
||||
where
|
||||
getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
||||
getSynchronised = do
|
||||
resId <- view $ _1 . _entityKey
|
||||
syncs <- lift . lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
|
||||
E.on $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. user E.^. UserId
|
||||
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult E.==. E.val resId
|
||||
return ( examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice
|
||||
, ( user E.^. UserDisplayName
|
||||
, user E.^. UserSurname
|
||||
, examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime
|
||||
, examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool
|
||||
)
|
||||
)
|
||||
let syncs' = Map.fromListWith
|
||||
(\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs'))
|
||||
[ ((officeId, t), (dn, sn, t, maybe Set.empty Set.singleton ssh'))
|
||||
| (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs
|
||||
]
|
||||
return $ Map.elems syncs'
|
||||
|
||||
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do
|
||||
syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised
|
||||
lastChange <- view $ resultResult . _entityVal . _externalExamResultLastChanged
|
||||
user <- view $ resultUser . _entityVal
|
||||
isSynced <- view resultIsSynced
|
||||
let
|
||||
hasSyncs = has folded syncs
|
||||
|
||||
syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange]
|
||||
++ [ Left lastChange ]
|
||||
++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
|
||||
|
||||
syncIcon :: Widget
|
||||
syncIcon
|
||||
| not isSynced
|
||||
, not hasSyncs
|
||||
= mempty
|
||||
| not isSynced
|
||||
= toWidget iconNotOK
|
||||
| otherwise
|
||||
= toWidget iconOK
|
||||
|
||||
syncsModal :: Widget
|
||||
syncsModal = $(widgetFile "exam-office/exam-result-synced")
|
||||
lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ case mode of
|
||||
EEUMGrades -> mconcat
|
||||
[ dbSelect (applying _2) id $ return . view (resultResult . _entityKey)
|
||||
, colSynced
|
||||
]
|
||||
_other -> mempty
|
||||
, colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
|
||||
t <- view $ resultResult . _entityVal . _externalExamResultTime
|
||||
lift $ formatTimeW SelFormatDateTime t
|
||||
, colExamResult externalExamShowGrades (resultResult . _entityVal . _externalExamResultResult)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
||||
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, sortOccurrenceStart (queryResult . to (E.^. ExternalExamResultTime))
|
||||
, maybeOpticSortColumn (sortExamResult externalExamShowGrades) (queryResult . to (E.^. ExternalExamResultResult))
|
||||
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
|
||||
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, fltrExamResultPoints externalExamShowGrades (queryResult . to (E.^. ExternalExamResultResult))
|
||||
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrExamResultPointsUI externalExamShowGrades
|
||||
, case mode of
|
||||
EEUMGrades ->
|
||||
\mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
|
||||
_other -> mempty
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = case mode of
|
||||
EEUMGrades -> FormSubmit
|
||||
_other -> FormNoSubmit
|
||||
, dbParamsFormAdditional = case mode of
|
||||
EEUMGrades -> \csrf -> do
|
||||
let
|
||||
actionMap :: Map ExternalExamUserAction (AForm Handler ExternalExamUserActionData)
|
||||
actionMap = Map.fromList
|
||||
[ ( ExternalExamUserMarkSynchronised
|
||||
, pure ExternalExamUserMarkSynchronisedData
|
||||
)
|
||||
]
|
||||
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
||||
let formRes = (, mempty) . First . Just <$> res
|
||||
return (formRes, formWgt)
|
||||
_other -> \csrf -> return (FormMissing, toWidget csrf)
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtIdent = mode
|
||||
dbtCsvEncode = Nothing
|
||||
dbtCsvDecode
|
||||
| mode == EEUMUsers = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
pid <- lift $ guessUser' csv
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueExternalExamResult eeId pid
|
||||
, dbtCsvComputeActions = \case
|
||||
DBCsvDiffMissing{dbCsvOldKey}
|
||||
-> yield . ExternalExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
||||
DBCsvDiffNew{dbCsvNewKey = Just _}
|
||||
-> error "An UniqueExternalExamResult could be found, but the ExternalExamResultKey is not among the existing keys"
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
pid <- lift $ guessUser' dbCsvNew
|
||||
let ExternalExamUserTableCsv{..} = dbCsvNew
|
||||
yield $ ExternalExamUserCsvRegisterData pid (zonedTimeToUTC csvEUserOccurrenceStart) csvEUserExamResult
|
||||
DBCsvDiffExisting{..} -> do
|
||||
let ExternalExamUserTableCsv{..} = dbCsvNew
|
||||
when (zonedTimeToUTC csvEUserOccurrenceStart /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
|
||||
yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) (zonedTimeToUTC csvEUserOccurrenceStart)
|
||||
|
||||
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult . to resultView) $
|
||||
yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
|
||||
, dbtCsvClassifyAction = \case
|
||||
ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister
|
||||
ExternalExamUserCsvSetTimeData{} -> ExternalExamUserCsvSetTime
|
||||
ExternalExamUserCsvSetResultData{} -> ExternalExamUserCsvSetResult
|
||||
ExternalExamUserCsvDeregisterData{} -> ExternalExamUserCsvDeregister
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
ExternalExamUserCsvRegister -> DBCsvActionNew
|
||||
ExternalExamUserCsvDeregister -> DBCsvActionMissing
|
||||
_other -> DBCsvActionExisting
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \case
|
||||
ExternalExamUserCsvRegisterData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
|
||||
insert_ ExternalExamResult
|
||||
{ externalExamResultExam = eeId
|
||||
, externalExamResultUser = externalExamUserCsvActUser
|
||||
, externalExamResultTime = externalExamUserCsvActTime
|
||||
, externalExamResultResult = res'
|
||||
, externalExamResultLastChanged = now
|
||||
}
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamUserCsvActUser
|
||||
ExternalExamUserCsvSetTimeData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
|
||||
[ ExternalExamResultTime =. externalExamUserCsvActTime
|
||||
, ExternalExamResultLastChanged =. now
|
||||
]
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
||||
ExternalExamUserCsvSetResultData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
|
||||
ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
|
||||
[ ExternalExamResultResult =. res'
|
||||
, ExternalExamResultLastChanged =. now
|
||||
]
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
||||
ExternalExamUserCsvDeregisterData{..} -> do
|
||||
ExternalExamResult{..} <- getJust externalExamUserCsvActRegistration
|
||||
delete externalExamUserCsvActRegistration
|
||||
audit $ TransactionExternalExamResultDelete eeId externalExamResultUser
|
||||
return $ EExamR tid ssh coursen examn EEUsersR
|
||||
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
||||
ExternalExamUserCsvRegisterData{..} -> do
|
||||
User{..} <- liftHandler . runDB $ getJust externalExamUserCsvActUser
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
, ^{formatTimeW SelFormatDateTime externalExamUserCsvActTime}
|
||||
, _{externalExamUserCsvActResult}
|
||||
|]
|
||||
ExternalExamUserCsvSetTimeData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{registeredUserName' externalExamUserCsvActRegistration}
|
||||
, ^{formatTimeW SelFormatDateTime externalExamUserCsvActTime}
|
||||
|]
|
||||
ExternalExamUserCsvSetResultData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{registeredUserName' externalExamUserCsvActRegistration}
|
||||
, _{externalExamUserCsvActResult}
|
||||
|]
|
||||
ExternalExamUserCsvDeregisterData{..} ->
|
||||
registeredUserName' externalExamUserCsvActRegistration
|
||||
, dbtCsvRenderActionClass = i18n
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
||||
}
|
||||
| otherwise = Nothing
|
||||
where
|
||||
registeredUserName :: Map (E.Value ExternalExamResultId) ExternalExamUserTableData -> ExternalExamResultId -> Widget
|
||||
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
||||
where
|
||||
Entity _ User{..} = view resultUser $ existing Map.! registration
|
||||
|
||||
guessUser' :: ExternalExamUserTableCsv -> DB UserId
|
||||
guessUser' ExternalExamUserTableCsv{..} = do
|
||||
let criteria = Set.fromList $ catMaybes
|
||||
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
|
||||
, GuessUserDisplayName <$> csvEUserName
|
||||
, GuessUserSurname <$> csvEUserSurname
|
||||
, GuessUserFirstName <$> csvEUserFirstName
|
||||
]
|
||||
maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
|
||||
externalExamUsersDBTableValidator = def
|
||||
& defaultSorting (bool id (SortAscBy "is-synced" :) (mode == EEUMGrades) [SortAscBy "user-name"])
|
||||
& defaultPagesize PagesizeAll
|
||||
|
||||
postprocess :: FormResult (First ExternalExamUserActionData, DBFormResult ExternalExamResultId Bool ExternalExamUserTableData) -> FormResult (ExternalExamUserActionData, Set ExternalExamResultId)
|
||||
postprocess inp = do
|
||||
(First (Just act), regMap) <- inp
|
||||
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
|
||||
return (act, regSet)
|
||||
|
||||
over _1 postprocess <$> dbTable externalExamUsersDBTableValidator DBTable{..}
|
||||
@ -2,9 +2,12 @@ module Handler.Utils.Users
|
||||
( computeUserAuthenticationDigest
|
||||
, Digest, SHA3_256
|
||||
, constEq
|
||||
, GuessUserInfo(..)
|
||||
, guessUser
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Auth.LDAP (campusUserMatr')
|
||||
|
||||
import Crypto.Hash (Digest, SHA3_256, hashlazy)
|
||||
|
||||
@ -12,6 +15,74 @@ import Data.ByteArray (constEq)
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
|
||||
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
||||
|
||||
|
||||
data GuessUserInfo
|
||||
= GuessUserMatrikelnummer { guessUserMatrikelnummer :: UserMatriculation }
|
||||
| GuessUserDisplayName { guessUserDisplayName :: UserDisplayName }
|
||||
| GuessUserSurname { guessUserSurname :: UserSurname }
|
||||
| GuessUserFirstName { guessUserFirstName :: UserFirstName }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Binary GuessUserInfo
|
||||
|
||||
makeLenses_ ''GuessUserInfo
|
||||
|
||||
guessUser :: Set GuessUserInfo -> DB (Maybe UserId)
|
||||
guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
||||
where
|
||||
toSql user = \case
|
||||
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
||||
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `E.hasInfix` E.val userDisplayName'
|
||||
GuessUserSurname userSurname' -> user E.^. UserSurname `E.hasInfix` E.val userSurname'
|
||||
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `E.hasInfix` E.val userFirstName'
|
||||
|
||||
go didLdap = do
|
||||
let retrieveUsers = E.select . E.from $ \user -> do
|
||||
E.where_ . E.or $ map (toSql user) criteria
|
||||
return user
|
||||
users <- retrieveUsers
|
||||
let users' = reverse $ sortBy closeness users
|
||||
|
||||
matchesMatriculation :: Entity User -> Maybe Bool
|
||||
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> all ((== userMatr) . Just) $ criteria ^.. folded . _guessUserMatrikelnummer)
|
||||
|
||||
closeness :: Entity User -> Entity User -> Ordering
|
||||
closeness = mconcat $ concat
|
||||
[ pure $ comparing (fmap Down . matchesMatriculation)
|
||||
, (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (preview $ _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
|
||||
, (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (preview $ _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
|
||||
, (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (preview $ _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
|
||||
]
|
||||
|
||||
doLdap userMatr = do
|
||||
app <- getYesod
|
||||
let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
|
||||
fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
|
||||
ldapData <- campusUserMatr' ldapConf ldapPool userMatr
|
||||
for ldapData $ upsertCampusUser UpsertCampusUser
|
||||
|
||||
|
||||
case users' of
|
||||
x@(Entity pid _) : xs
|
||||
| [] <- xs
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
-> return $ Just pid
|
||||
| x' : _ <- xs
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
, GT <- x `closeness` x'
|
||||
-> return $ Just pid
|
||||
| not didLdap
|
||||
, userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
|
||||
, all (== userMatr) userMatrs'
|
||||
-> doLdap userMatr >>= maybe (go True) (return . Just)
|
||||
_other
|
||||
-> return Nothing
|
||||
|
||||
@ -6,7 +6,6 @@ module Jobs.Handler.SynchroniseLdap
|
||||
import Import
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Auth.LDAP
|
||||
|
||||
@ -48,11 +47,7 @@ dispatchJobSynchroniseLdapUser jUser = do
|
||||
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
|
||||
|
||||
ldapAttrs <- MaybeT $ campusUser' ldapConf ldapPool user
|
||||
void . lift $ upsertCampusUser ldapAttrs Creds
|
||||
{ credsIdent = CI.original userIdent
|
||||
, credsPlugin = "dummy"
|
||||
, credsExtra = []
|
||||
}
|
||||
void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
|
||||
Nothing ->
|
||||
throwM SynchroniseLdapNoLdap
|
||||
where
|
||||
|
||||
@ -223,6 +223,7 @@ makeLenses_ ''SessionFile
|
||||
|
||||
makeLenses_ ''ExternalExamOfficeSchool
|
||||
makeLenses_ ''ExternalExamStaff
|
||||
makeLenses_ ''ExternalExamResult
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
Loading…
Reference in New Issue
Block a user