From 1d14b6a69cc569e3924523d4270a897c7529281a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 Jan 2020 16:12:24 +0100 Subject: [PATCH] feat: external exam csv import & ldap lookup during csv import --- messages/uniworx/de-de-formal.msg | 14 + src/Audit/Types.hs | 9 + src/Auth/LDAP.hs | 51 ++- src/Foundation.hs | 117 +++-- src/Handler/Exam/Users.hs | 49 +-- src/Handler/ExamOffice/Exam.hs | 18 +- src/Handler/ExamOffice/ExternalExam.hs | 12 +- src/Handler/ExternalExam/Users.hs | 10 +- src/Handler/Utils/ExamOffice/ExternalExam.hs | 24 +- src/Handler/Utils/ExternalExam/Users.hs | 430 +++++++++++++++++++ src/Handler/Utils/Users.hs | 71 +++ src/Jobs/Handler/SynchroniseLdap.hs | 7 +- src/Utils/Lens.hs | 1 + 13 files changed, 705 insertions(+), 108 deletions(-) create mode 100644 src/Handler/Utils/ExternalExam/Users.hs diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 95cb9df15..3dbd1b138 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index c065c1f36..88add95c9 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 5acb12e95..9db9fa7fb 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 117ebd26c..96ed2e3fc 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 046d6c7f4..39624ab04 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -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) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 320822663..0e3d0bce2 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -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 diff --git a/src/Handler/ExamOffice/ExternalExam.hs b/src/Handler/ExamOffice/ExternalExam.hs index 2b114c2cf..43526eb54 100644 --- a/src/Handler/ExamOffice/ExternalExam.hs +++ b/src/Handler/ExamOffice/ExternalExam.hs @@ -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 diff --git a/src/Handler/ExternalExam/Users.hs b/src/Handler/ExternalExam/Users.hs index 8fc8eb3ef..163d086fa 100644 --- a/src/Handler/ExternalExam/Users.hs +++ b/src/Handler/ExternalExam/Users.hs @@ -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 diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index ec32091d9..76a24139c 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -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) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs new file mode 100644 index 000000000..55addd2a9 --- /dev/null +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -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{..} diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f7fdfda79..edf68ba4f 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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 diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 031a5862b..3769f76a4 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 28482cb8c..8a2de3fc8 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -223,6 +223,7 @@ makeLenses_ ''SessionFile makeLenses_ ''ExternalExamOfficeSchool makeLenses_ ''ExternalExamStaff +makeLenses_ ''ExternalExamResult -- makeClassy_ ''Load