feat: external exam csv import & ldap lookup during csv import

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

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

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
+findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
-      , Ldap.size 2
+findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
-      , Ldap.time ldapSearchTimeout
+  where
-      , Ldap.derefAliases Ldap.DerefAlways
+    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.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
-            [ Ldap.scope Ldap.BaseObject
-            , Ldap.size 2
-            , Ldap.time ldapSearchTimeout
-            , Ldap.derefAliases Ldap.DerefAlways
-            ]
-      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings 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

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-school", CI.original $ unSchoolKey ssh)
-                                                 , ("corrections-course", original csh)
+                                                 , ("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-school", CI.original $ unSchoolKey ssh)
-                                                 , ("corrections-course", original csh)
+                                                 , ("corrections-course", CI.original csh)
-                                                 , ("corrections-sheet" , original shn)
+                                                 , ("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)
+data UpsertCampusUserMode
-upsertCampusUser ldapData Creds{..} = do
+  = 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 $ CI.mk credsIdent
-        uAuth = UniqueAuthentication userIdent
+        upsertMode = creds ^? _upsertCampusUserMode
 
-        isDummy = credsPlugin == "dummy"
+        isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
-        isPWHash = credsPlugin == "PWHash"
+        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
+        Just (ldapConf, ldapPool)
-          let userCreds = Creds credsPlugin (original userIdent) credsExtra
+          | Just upsertMode' <- upsertMode -> do
-          ldapData <- campusUser ldapConf ldapPool userCreds
+              ldapData <- campusUser ldapConf ldapPool Creds{..}
-          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
+              $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-          Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
+              Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
-        Nothing
+        _other
           -> acceptExisting
 
     authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes

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 -> DB (Bool, UserId)
-              guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
+              guessUser' ExamUserTableCsv{..} = do
-                users <- E.select . E.from $ \user -> do
+                let criteria = Set.fromList $ catMaybes 
-                  E.where_ . E.or $ catMaybes
+                      [ GuessUserMatrikelnummer <$> csvEUserMatriculation
-                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
+                      , GuessUserDisplayName <$> csvEUserName
-                    , (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName
+                      , GuessUserSurname <$> csvEUserSurname
-                    , (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname
+                      , GuessUserFirstName <$> csvEUserFirstName
-                    , (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))
                       ]
-                case users' of
+                pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
-                  [(E.Value isPart, Entity uid _)]
+                (,) <$> existsBy (UniqueParticipant pid examCourse) <*> pure pid
-                      -> return (isPart, uid)
-                  (x@(E.Value isPart, Entity uid _) : x' : _)
-                    | GT <- x `closeness` x'
-                      -> return (isPart, uid)
-                  _other
-                    -> throwM ExamUserCsvExceptionNoMatchingUser
 
               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)

src/Handler/ExamOffice/Exam.hs

@@ -140,15 +140,15 @@ resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname
 resultSynchronised = _dbrOutput . _9 . traverse
 
 data ExamUserTableCsv = ExamUserTableCsv
-  { csvEUserSurname :: Text
+  { csvEUserSurname         :: Text
-  , csvEUserFirstName :: Text
+  , csvEUserFirstName       :: Text
-  , csvEUserName :: Text
+  , csvEUserName            :: Text
-  , csvEUserMatriculation :: Maybe Text
+  , csvEUserMatriculation   :: Maybe Text
-  , csvEUserField :: Maybe Text
+  , csvEUserField           :: Maybe Text
-  , csvEUserDegree :: Maybe Text
+  , csvEUserDegree          :: Maybe Text
-  , csvEUserSemester :: Maybe Int
+  , 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

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

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

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)

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{..}

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

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
+        void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
-          { credsIdent  = CI.original userIdent
-          , credsPlugin = "dummy"
-          , credsExtra  = []
-          }
     Nothing ->
       throwM SynchroniseLdapNoLdap
   where

src/Utils/Lens.hs

@@ -223,6 +223,7 @@ makeLenses_ ''SessionFile
   
 makeLenses_ ''ExternalExamOfficeSchool
 makeLenses_ ''ExternalExamStaff
+makeLenses_ ''ExternalExamResult
   
 
 -- makeClassy_ ''Load