diff --git a/CHANGELOG.md b/CHANGELOG.md index 8bf5c370c..eafe33cf7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,32 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.7.0...v4.8.0) (2019-07-31) + + +### Bug Fixes + +* **exam add users:** correctly differentiate and fix messages ([a473599](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a473599)) + + +### Features + +* **exams:** better explain "enlist directly" ([f07eb3d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f07eb3d)) + + + +## [4.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.6.0...v4.7.0) (2019-07-30) + + +### Features + +* **exam users:** course notes ([1e756be](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/1e756be)) +* **notification triggers:** redesign interface ([84c12b5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/84c12b5)), closes [#410](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/410) +* **users:** lecturer invitations ([e6c3be4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e6c3be4)) +* **users:** switching between AuthModes & password changing ([0d610cc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d610cc)) + + + ## [4.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.5.0...v4.6.0) (2019-07-26) diff --git a/default.nix b/default.nix index 21608bb19..aa23072f4 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ argumentPackages@{ ... }: let - defaultPackages = (import {}).haskellPackages; + defaultPackages = (import ./stackage.nix {}); haskellPackages = defaultPackages // argumentPackages; in import ./uniworx.nix { inherit (haskellPackages) callPackage; } diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 833df71e9..ea133aa73 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -553,6 +553,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp DummyLoginTitle: Development-Login LoginNecessary: Bitte melden Sie sich dazu vorher an! +InternalLdapError: Interner Fehler beim Campus-Login + +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 +CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln +CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln +CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln +CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr} + CorrectorNormal: Normal CorrectorMissing: Abwesend CorrectorExcused: Entschuldigt @@ -1110,6 +1120,7 @@ ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurd ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Klausur angemeldet ExamRegistrationInviteDeadline: Einladung nur gültig bis ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen +ExamRegistrationEnlistDirectlyTip: Sollen, wenn manche der E-Mail Addressen bereits in Uni2work mit Nutzern assoziiert sind, jene Nutzer direkt zur Klausur hinzugefügt werden? Ansonsten werden Einladung an alle E-Mail Addressen (nicht nur unbekannte) versandt, die die Nutzer zunächst akzeptieren müssen um Klausurteilnehmer zu werden. ExamRegistrationRegisterCourse: Nutzer auch zum Kurs anmelden ExamRegistrationRegisterCourseTip: Nutzer, die keine Kursteilnehmer sind, werden sonst nicht zur Klausur angemeldet. ExamRegistrationInviteField: Einzuladende EMail Addressen @@ -1278,6 +1289,7 @@ CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilneh CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") +CsvColumnExamUserCourseNote: Notizen zum Teilnehmer Action: Aktion @@ -1292,6 +1304,9 @@ ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern ExamUserCsvSetResult: Ergebnis eintragen +ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen + +ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden diff --git a/nixpkgs.nix b/nixpkgs.nix new file mode 100644 index 000000000..f21a81350 --- /dev/null +++ b/nixpkgs.nix @@ -0,0 +1,9 @@ +{ nixpkgs ? import +}: + +import ((nixpkgs {}).fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "19.03"; + sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; +}) diff --git a/package-lock.json b/package-lock.json index ff669ca94..289d2983f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.6.0", + "version": "4.8.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index de7966735..8fc8b4f5c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.6.0", + "version": "4.8.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index a935edb8d..c9a2dc630 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.6.0 +version: 4.8.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage diff --git a/shell.nix b/shell.nix index b942f99b9..d65bb65a3 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import }: +{ nixpkgs ? import ./nixpkgs.nix {} }: let inherit (nixpkgs {}) pkgs; diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 4f003471a..26026dfee 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,9 +1,12 @@ module Auth.LDAP - ( campusLogin + ( apLdap + , campusLogin , CampusUserException(..) , campusUser , CampusMessage(..) - , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue + , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName + , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname + , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName ) where import Import.NoFoundation hiding (userEmail, userDisplayName) @@ -42,12 +45,12 @@ 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 where userFilters = - [ userPrincipalName Ldap.:= Text.encodeUtf8 ident - , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 ident - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userDisplayName Ldap.:= Text.encodeUtf8 ident + [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident + , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 ident + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident ] userSearchSettings = mconcat [ Ldap.scope ldapScope @@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not , Ldap.derefAliases Ldap.DerefAlways ] -userPrincipalName, userEmail, userDisplayName :: Ldap.Attr -userPrincipalName = Ldap.Attr "userPrincipalName" -userEmail = Ldap.Attr "mail" -userDisplayName = Ldap.Attr "displayName" +ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr +ldapUserPrincipalName = Ldap.Attr "userPrincipalName" +ldapUserEmail = Ldap.Attr "mail" +ldapUserDisplayName = Ldap.Attr "displayName" +ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" +ldapUserFirstName = Ldap.Attr "givenName" +ldapUserSurname = Ldap.Attr "sn" +ldapUserTitle = Ldap.Attr "title" +ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" +ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString" + + +data CampusUserException = CampusUserLdapError LdapPoolError + | CampusUserHostNotResolved String + | CampusUserLineTooLong + | CampusUserHostCannotConnect String [IOException] + | CampusUserNoResult + | CampusUserAmbiguous + deriving (Show, Eq, Generic, Typeable) + +instance Exception CampusUserException + +campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do + Ldap.bind ldap ldapDn ldapPassword + 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 [] + Nothing -> do + findUser conf ldap credsIdent [] + 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 + ] + campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage @@ -69,6 +115,9 @@ campusForm = CampusLogin <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing +apLdap :: Text +apLdap = "LDAP" + campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage @@ -78,7 +127,7 @@ campusLogin :: forall site. ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where - apName = "LDAP" + apName = apLdap apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent apDispatch "POST" [] = do ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm @@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do ldapResult <- withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword - searchResults <- findUser conf ldap campusIdent [userPrincipalName] + searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] - | Just [principalName] <- lookup userPrincipalName userAttrs + | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ] , Right credsIdent <- Text.decodeUtf8' principalName -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) other -> return $ Left other @@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} , formAnchor = Just "login--campus" :: Maybe Text } $(widgetFile "widgets/campus-login/campus-login-form") - -data CampusUserException = CampusUserLdapError LdapPoolError - | CampusUserHostNotResolved String - | CampusUserLineTooLong - | CampusUserHostCannotConnect String [IOException] - | CampusUserNoResult - | CampusUserAmbiguous - deriving (Show, Eq, Generic, Typeable) - -instance Exception CampusUserException - -campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) -campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do - Ldap.bind ldap ldapDn ldapPassword - results <- case lookup "DN" credsExtra of - Just userDN -> do - let userFilter = Ldap.Present userPrincipalName - userSearchSettings = mconcat - [ 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 - [] -> 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 - ] - --- ldapConfig :: UniWorX -> LDAPConfig --- ldapConfig _app@(appSettings' -> settings) = LDAPConfig --- { usernameFilter = \u -> principalName <> "=" <> u --- , identifierModifier --- , ldapUri = appLDAPURI settings --- , initDN = appLDAPDN settings --- , initPass = appLDAPPw settings --- , baseDN = appLDAPBaseName settings --- , ldapScope = LdapScopeSubtree --- } --- where --- principalName :: IsString a => a --- principalName = "userPrincipalName" --- identifierModifier _ entry = case lookup principalName $ leattrs entry of --- Just [n] -> Text.pack n --- _ -> error "Could not determine user principal name" diff --git a/src/Foundation.hs b/src/Foundation.hs index 8998e23cc..2d67f1f9e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -55,7 +55,7 @@ import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E -import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) +import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) @@ -88,6 +88,8 @@ import qualified Data.Aeson as JSON import Data.FileEmbed (embedFile) +import qualified Ldap.Client as Ldap + type SMTPPool = Pool SMTPConnection @@ -2732,6 +2734,155 @@ instance YesodPersist UniWorX where instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool +data CampusUserConversionException + = CampusUserInvalidEmail + | CampusUserInvalidDisplayName + | CampusUserInvalidGivenName + | CampusUserInvalidSurname + | CampusUserInvalidTitle + | CampusUserInvalidMatriculation + | CampusUserInvalidFeaturesOfStudy String + deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance Exception CampusUserConversionException + +embedRenderMessage ''UniWorX ''CampusUserConversionException id + +upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User) +upsertCampusUser ldapData Creds{..} = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + + let + userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] + userEmail' = fold [ v | (k, v) <- ldapData, k == ldapUserEmail ] + userDisplayName' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] + userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] + userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] + userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] + + userAuthentication + | isPWHash = error "PWHash should only work for users that are already known" + | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (not isDummy) + + userEmail <- if + | [bs] <- userEmail' + , Right userEmail <- Text.decodeUtf8' bs + -> return $ mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + userDisplayName <- if + | [bs] <- userDisplayName' + , Right userDisplayName <- Text.decodeUtf8' bs + -> return userDisplayName + | otherwise + -> throwM CampusUserInvalidDisplayName + userFirstName <- if + | [bs] <- userFirstName' + , Right userFirstName <- Text.decodeUtf8' bs + -> return userFirstName + | otherwise + -> throwM CampusUserInvalidGivenName + userSurname <- if + | [bs] <- userSurname' + , Right userSurname <- Text.decodeUtf8' bs + -> return userSurname + | otherwise + -> throwM CampusUserInvalidSurname + userTitle <- if + | all ByteString.null userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userMatrikelnummer <- if + | [bs] <- userMatrikelnummer' + , Right userMatrikelnummer <- Text.decodeUtf8' bs + -> return $ Just userMatrikelnummer + | [] <- userMatrikelnummer' + -> return Nothing + | otherwise + -> throwM CampusUserInvalidMatriculation + + let + newUser = User + { userIdent = mk credsIdent + , userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userNotificationSettings = def + , userMailLanguages = def + , userTokensIssuedAfter = Nothing + , .. + } + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , UserEmail =. userEmail + ] ++ + [ UserLastAuthentication =. Just now | not isDummy ] + + user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate + + let + userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now + userStudyFeatures' = do + (k, v) <- ldapData + guard $ k == ldapUserStudyFeatures + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + termNames = nubBy ((==) `on` mk) $ do + (k, v) <- ldapData + guard $ k == ldapUserFieldName + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures + + let + studyTermCandidates = Set.fromList $ do + name <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs + return (key, name) + studyTermCandidateIncidence + = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen + . UUID.fromByteString + . fromStrict + . (convert :: Digest (SHAKE128 128) -> ByteString) + . runIdentity + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + + [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate -> + E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence + + unless candidatesRecorded $ do + let + studyTermCandidates' = do + (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates + return StudyTermCandidate{..} + insertMany_ studyTermCandidates' + + E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] + forM_ fs $ \f@StudyFeatures{..} -> do + insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing + insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] + + return user + where + insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) + isDummy = credsPlugin == "dummy" + isPWHash = credsPlugin == "PWHash" + + instance YesodAuth UniWorX where type AuthId UniWorX = UserId @@ -2761,25 +2912,34 @@ instance YesodAuth UniWorX where isDummy = credsPlugin == "dummy" isPWHash = credsPlugin == "PWHash" - excHandlers + excRecovery res | isDummy || isPWHash - = [ C.Handler $ \err -> do - addMessage Error (toHtml $ tshow (err :: CampusUserException)) - $logErrorS "LDAP" $ tshow err - acceptExisting - ] + = do + case res of + UserError err -> addMessageI Error err + ServerError err -> addMessage Error $ toHtml err + _other -> return () + acceptExisting | otherwise - = [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "LDAP" $ tshow err - return $ ServerError "LDAP lookup failed" - ] + = return res + + excHandlers = + [ C.Handler $ \case + CampusUserNoResult -> do + $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + CampusUserAmbiguous -> do + $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + err -> do + $logErrorS "LDAP" $ tshow err + mr <- getMessageRender + excRecovery . ServerError $ mr MsgInternalLdapError + , C.Handler $ \(cExc :: CampusUserConversionException) -> do + $logErrorS "LDAP" $ tshow cExc + mr <- getMessageRender + excRecovery . ServerError $ mr cExc + ] acceptExisting = do res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth @@ -2792,138 +2952,13 @@ instance YesodAuth UniWorX where UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of - Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra + Just (ldapConf, ldapPool) -> do + let userCreds = Creds credsPlugin (original userIdent) credsExtra + ldapData <- campusUser ldapConf ldapPool userCreds $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - - let - userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData - userEmail' = lookup (Attr "mail") ldapData - userDisplayName' = lookup (Attr "displayName") ldapData - userFirstName' = lookup (Attr "givenName") ldapData - userSurname' = lookup (Attr "sn") ldapData - userTitle' = lookup (Attr "title") ldapData - - userAuthentication - | isPWHash = error "PWHash should only work for users that are already known" - | otherwise = AuthLDAP - userLastAuthentication = now <$ guard (not isDummy) - - userEmail <- if - | Just [bs] <- userEmail' - , Right userEmail <- Text.decodeUtf8' bs - -> return $ mk userEmail - | otherwise - -> throwError $ ServerError "Could not retrieve user email" - userDisplayName <- if - | Just [bs] <- userDisplayName' - , Right userDisplayName <- Text.decodeUtf8' bs - -> return userDisplayName - | otherwise - -> throwError $ ServerError "Could not retrieve user name" - userFirstName <- if - | Just [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwError $ ServerError "Could not retrieve user given name" - userSurname <- if - | Just [bs] <- userSurname' - , Right userSurname <- Text.decodeUtf8' bs - -> return userSurname - | otherwise - -> throwError $ ServerError "Could not retrieve user surname" - userTitle <- if - | maybe True (all ByteString.null) userTitle' - -> return Nothing - | Just [bs] <- userTitle' - , Right userTitle <- Text.decodeUtf8' bs - -> return $ Just userTitle - | otherwise - -> throwError $ ServerError "Could not retrieve user title" - userMatrikelnummer <- if - | Just [bs] <- userMatrikelnummer' - , Right userMatrikelnummer <- Text.decodeUtf8' bs - -> return $ Just userMatrikelnummer - | Nothing <- userMatrikelnummer' - -> return Nothing - | otherwise - -> throwError $ ServerError "Could not decode user matriculation" - - let - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userNotificationSettings = def - , userMailLanguages = def - , userTokensIssuedAfter = Nothing - , .. - } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail - ] ++ - [ UserLastAuthentication =. Just now | not isDummy ] - - userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - - let - userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now - userStudyFeatures' = do - (k, v) <- ldapData - guard $ k == Attr "dfnEduPersonFeaturesOfStudy" - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - termNames = nubBy ((==) `on` mk) $ do - (k, v) <- ldapData - guard $ k == Attr "dfnEduPersonFieldOfStudyString" - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - - let - studyTermCandidates = Set.fromList $ do - name <- termNames - StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs - return (key, name) - studyTermCandidateIncidence - = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") - . UUID.fromByteString - . fromStrict - . (convert :: Digest (SHAKE128 128) -> ByteString) - . runIdentity - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash - - [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate -> - E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence - - unless candidatesRecorded $ do - let - studyTermCandidates' = do - (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates - return StudyTermCandidate{..} - lift $ insertMany_ studyTermCandidates' - - lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] - forM_ fs $ \f@StudyFeatures{..} -> do - lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing - lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] - - return $ Authenticated userId - Nothing -> acceptExisting - - where - insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) + Authenticated . entityKey <$> upsertCampusUser ldapData userCreds + Nothing + -> acceptExisting authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes [ campusLogin <$> appLdapConf <*> appLdapPool diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c7e8c7cb6..aae2bc46a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -25,5 +25,4 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared? -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = postCNotesR -postCNotesR _ _ _ = do - defaultLayout $ [whamlet|You have corrector access to this course.|] +postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 3426bb872..24e95743c 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -128,20 +128,20 @@ postCAddUserR tid ssh csh = do -- register known users execWriterT $ mapM (registerUser cid) uids - when (not $ null emails) $ + unless (null emails) $ tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - when (not $ null aurAlreadyRegistered) $ do + unless (null aurAlreadyRegistered) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - when (not $ null aurNoUniquePrimaryField) $ do + unless (null aurNoUniquePrimaryField) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - when (not $ null aurSuccess) $ + unless (null aurSuccess) $ tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index b34b52288..f100a8d38 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -27,7 +27,8 @@ data AddRecipientsResult = AddRecipientsResult { aurAlreadyRegistered , aurNoUniquePrimaryField , aurNoCourseRegistration - , aurSuccess :: [UserEmail] + , aurSuccess + , aurSuccessCourse :: [UserEmail] } deriving (Read, Show, Generic, Typeable) instance Monoid AddRecipientsResult where @@ -66,7 +67,7 @@ postEAddUserR tid ssh csh examn = do = tomorrowEndOfDay deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) - enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False) + enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False) registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False) occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) @@ -87,7 +88,7 @@ postEAddUserR tid ssh csh examn = do processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler () processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do let (emails,uids) = partitionEithers $ Set.toList users - AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do + AddRecipientsResult{..} <- lift . runDBJobs $ do -- send Invitation eMails to unkown users sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails] -- register known users @@ -96,21 +97,21 @@ postEAddUserR tid ssh csh examn = do unless (null emails) $ tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails - unless (null alreadyRegistered) $ - tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField + unless (null aurSuccess) $ + tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess - unless (null registeredNoField) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|] + unless (null aurNoUniquePrimaryField) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|] modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - unless (null noCourseRegistration) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|] + unless (null aurNoCourseRegistration) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|] modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) - unless (null registeredOneField) $ - tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField + unless (null aurSuccessCourse) $ + tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length aurSuccessCourse registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () registerUser cid eid registerCourse occId uid = exceptT tell tell $ do @@ -149,6 +150,6 @@ postEAddUserR tid ssh csh examn = do return $ case courseParticipantField of Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccess = pure userEmail } + Just _ -> mempty { aurSuccessCourse = pure userEmail } diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index ca8599861..20966b7da 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -36,8 +36,8 @@ import Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult)) +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -49,25 +49,28 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 4 2) +queryExamOccurrence = $(sqlLOJproj 5 2) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) -queryExamResult = $(sqlLOJproj 4 4) +queryExamResult = $(sqlLOJproj 5 4) + +queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) +queryCourseNote = $(sqlLOJproj 5 5) resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration = _dbrOutput . _1 @@ -90,6 +93,9 @@ resultExamOccurrence = _dbrOutput . _3 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _7 . _Just +resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) +resultCourseNote = _dbrOutput . _8 . _Just + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text , csvEUserFirstName :: Maybe Text @@ -104,6 +110,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , csvEUserCourseNote :: Maybe Html } deriving (Generic) makeLenses_ ''ExamUserTableCsv @@ -130,6 +137,7 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:? "exercise-points-max" <*> csv .:? "exercise-num-passes-max" <*> csv .:? "exam-result" + <*> csv .:? "course-note" where (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a) m .:? name = Csv.lookup m name <|> return Nothing @@ -152,6 +160,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) + , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) ] data ExamUserAction = ExamUserDeregister @@ -171,8 +180,9 @@ data ExamUserCsvActionClass | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField - | ExamUserCsvDeregister | ExamUserCsvSetResult + | ExamUserCsvSetCourseNote + | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id @@ -201,6 +211,10 @@ data ExamUserCsvAction { examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) } + | ExamUserCsvSetCourseNoteData + { examUserCsvActUser :: UserId + , examUserCsvActCourseNote :: Maybe Html + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel @@ -236,7 +250,9 @@ postEUsersR tid ssh csh examn = do let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do + E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) + E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField @@ -248,7 +264,7 @@ postEUsersR tid ssh csh examn = do E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult) + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = mconcat $ catMaybes @@ -269,6 +285,8 @@ postEUsersR tid ssh csh examn = do return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) + , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) + -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -279,6 +297,11 @@ postEUsersR tid ssh csh examn = do , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) + , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date + E.sub_select . E.from $ \edit -> do + E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) + return . E.max_ $ edit E.^. CourseUserNoteEditTime + ) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -354,6 +377,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) + <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv @@ -376,6 +400,10 @@ postEUsersR tid ssh csh examn = do yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew + + note <- lift . getBy $ UniqueCourseUserNote uid examCourse + when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ + yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote dbCsvNew DBCsvDiffExisting{..} -> do newOccurrence <- lift $ lookupOccurrence dbCsvNew when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ @@ -388,6 +416,9 @@ postEUsersR tid ssh csh examn = do when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew + + when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ + yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew , dbtCsvClassifyAction = \case ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister ExamUserCsvRegisterData{} -> ExamUserCsvRegister @@ -395,6 +426,7 @@ postEUsersR tid ssh csh examn = do ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetResultData{} -> ExamUserCsvSetResult + ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew @@ -442,6 +474,16 @@ postEUsersR tid ssh csh examn = do User{userIdent} <- getJust examRegistrationUser audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent delete examUserCsvActRegistration + ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do + noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse + whenIsJust noteId $ \nid -> do + deleteWhere [CourseUserNoteEditNote ==. nid] + delete nid + ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do + now <- liftIO getCurrentTime + uid <- liftHandlerT requireAuthId + Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] + insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do @@ -502,7 +544,14 @@ postEUsersR tid ssh csh examn = do $nothing , _{MsgExamResultNone} |] - + ExamUserCsvSetCourseNoteData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $if isn't _Just examUserCsvActCourseNote + \ (_{MsgExamUserCsvCourseNoteDeleted}) + |] ExamUserCsvDeregisterData{..} -> registeredUserName' examUserCsvActRegistration , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 804359e44..59f5837c9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -260,10 +260,7 @@ postAdminUserR uuid = do campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf - let - campusLogin :: AuthPlugin UniWorX - campusLogin = Auth.campusLogin conf pool - void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) [] + void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 4bb875d02..5c9f83c42 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -31,8 +31,9 @@ deriving instance Typeable CsvParseError instance Exception CsvParseError -typeCsv :: ContentType +typeCsv, typeCsv' :: ContentType typeCsv = "text/csv" +typeCsv' = "text/csv; charset=UTF-8; header=present" extensionCsv :: Extension extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] @@ -57,7 +58,7 @@ respondCsv :: ( ToNamedRecord csv ) => Source (HandlerT site IO) csv -> HandlerT site IO TypedContent -respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk +respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk respondCsvDB :: ( ToNamedRecord csv , DefaultOrdered csv @@ -65,7 +66,7 @@ respondCsvDB :: ( ToNamedRecord csv ) => Source (YesodDB site) csv -> HandlerT site IO TypedContent -respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk +respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk fileSourceCsv :: ( FromNamedRecord csv , MonadResource m diff --git a/src/Text/Blaze/Instances.hs b/src/Text/Blaze/Instances.hs index 346b17c60..6bc967a9b 100644 --- a/src/Text/Blaze/Instances.hs +++ b/src/Text/Blaze/Instances.hs @@ -14,6 +14,8 @@ import Data.Hashable (Hashable(..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import qualified Data.Aeson as Aeson +import qualified Data.Csv as Csv + instance Eq Markup where (==) = (==) `on` Text.renderMarkup @@ -35,3 +37,9 @@ instance ToJSON Markup where instance FromJSON Markup where parseJSON = Aeson.withText "Html" $ return . preEscapedText + +instance Csv.ToField Markup where + toField = Csv.toField . Text.renderMarkup + +instance Csv.FromField Markup where + parseField = fmap preEscapedText . Csv.parseField diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7ef4d33a7..dd1cea10f 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence makePrisms ''AuthenticationMode +makeLenses_ ''CourseUserNote + -- makeClassy_ ''Load diff --git a/stack.nix b/stack.nix index c78220b4c..01d3ebc4f 100644 --- a/stack.nix +++ b/stack.nix @@ -1,4 +1,4 @@ -{ ghc, nixpkgs ? import }: +{ ghc, nixpkgs ? import ./nixpkgs.nix {} }: let haskellPackages = import ./stackage.nix { inherit nixpkgs; }; diff --git a/stackage.nix b/stackage.nix index 4fb2c4623..e16045a40 100644 --- a/stackage.nix +++ b/stackage.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import +{ nixpkgs ? import ./nixpkgs.nix {} , snapshot ? "lts-10.5" }: diff --git a/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet b/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet index 197c4e906..b67450643 100644 --- a/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet +++ b/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet @@ -1,5 +1,5 @@

- _{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)} + _{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}
    - $forall email <- noCourseRegistration + $forall email <- aurNoCourseRegistration
  • #{email} diff --git a/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet b/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet index 55f50ea70..41bd13e1a 100644 --- a/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet +++ b/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet @@ -1,5 +1,5 @@

    - _{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)} + _{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}
      - $forall email <- registeredNoField + $forall email <- aurNoUniquePrimaryField
    • #{email}