diff --git a/frontend/src/app.sass b/frontend/src/app.sass index a5195c783..dc26f1b5f 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -723,6 +723,10 @@ section .uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label font-family: var(--font-monospace) +.shown + font-family: var(--font-monospace) + white-space: pre-wrap + .token font-family: var(--font-monospace) white-space: pre-wrap diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 27e53f34e..b4213a860 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -775,6 +775,12 @@ AccessRightsNotChanged: Berechtigungen wurden nicht verändert UserSystemFunctions: Systemweite Rollen UserSystemFunctionsSaved: Systemweite Rollen gespeichert UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst +UserAssimilateUser: Benutzer +BtnUserAssimilate: Assimilieren +AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden +AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten +AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben +AssimilateUserSuccess: Benutzer erfolgreich assimiliert LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} @@ -2300,6 +2306,8 @@ UserDisplayEmail: Angezeigte E-Mail-Adresse UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzern mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse. UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail-Adresse wurden an „#{displayEmail}” versandt +UserCreated: Account erstellt + SchoolShort: Kürzel SchoolName: Name SchoolLdapOrganisations: Assoziierte LDAP-Fragmente @@ -2407,6 +2415,7 @@ AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer AdminUserSex: Geschlecht +AdminUserAssimilate: Benutzer assimilieren AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung UserAdded: Benutzer erfolgreich angelegt diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 437215ed3..c8cb2dbb9 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -771,6 +771,12 @@ AccessRightsNotChanged: Permissions left unchanged UserSystemFunctions: System wide roles UserSystemFunctionsSaved: Successfully saved system wide roles UserSystemFunctionsNotChanged: No system wide roles were changed +UserAssimilateUser: User +BtnUserAssimilate: Assimilate +AssimilateUserNotFound: Email could not be resolved to an user +AssimilateUserHaveError: An error occurred during assimilation +AssimilateUserHaveWarnings: Warnings were ermitted during assimilation +AssimilateUserSuccess: Successfully assimilated user LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"} @@ -2300,6 +2306,8 @@ UserDisplayEmail: Display email UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. Notifications and other communication from Uni2work or users with elevated permissions are always sent to your primary email address as specified under "personal information". UserDisplayEmailChangeSent displayEmail: Instructions to change your display email have been sent to “#{displayEmail}”. +UserCreated: Account created + SchoolShort: Shorthand SchoolName: Name SchoolLdapOrganisations: Associated LDAP fragments @@ -2407,6 +2415,7 @@ AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserMatriculation: Matriculation AdminUserSex: Sex +AdminUserAssimilate: Assimilate user AuthKindLDAP: Campus account AuthKindPWHash: Uni2work account UserAdded: Successfully added user diff --git a/models/allocations.model b/models/allocations.model index a8263979b..0bbebbea5 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -45,12 +45,14 @@ AllocationUser totalCourses Natural -- number of total allocated courses for this user must be <= than this number priority AllocationPriority Maybe UniqueAllocationUser allocation user + deriving Eq Ord Show AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) + deriving Eq Ord Show AllocationNotificationSetting user UserId diff --git a/models/courses.model b/models/courses.model index 0dfebc12f..6033ff0a9 100644 --- a/models/courses.model +++ b/models/courses.model @@ -60,6 +60,7 @@ CourseParticipant -- course enrolement allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course + deriving Eq Ord Show -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- course CourseId diff --git a/models/exams.model b/models/exams.model index 7fbe1251d..4963e4075 100644 --- a/models/exams.model +++ b/models/exams.model @@ -43,24 +43,28 @@ ExamRegistration occurrence ExamOccurrenceId Maybe time UTCTime default=now() UniqueExamRegistration exam user + deriving Eq Ord Show ExamPartResult examPart ExamPartId user UserId result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user + deriving Eq Ord Show ExamBonus exam ExamId user UserId bonus Points lastChanged UTCTime default=now() UniqueExamBonus exam user + deriving Eq Ord Show ExamResult exam ExamId user UserId result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user + deriving Eq Ord Show ExamCorrector exam ExamId user UserId diff --git a/models/external-exams.model b/models/external-exams.model index 945284399..0efe62669 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -13,6 +13,7 @@ ExternalExamResult time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user + deriving Eq Ord Show ExternalExamStaff user UserId exam ExternalExamId diff --git a/models/submissions.model b/models/submissions.model index f2c87fdc4..abfe0c6bd 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -31,3 +31,4 @@ SubmissionGroupUser -- Registered submission groups, just for check submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user + deriving Eq Ord Show \ No newline at end of file diff --git a/models/tutorials.model b/models/tutorials.model index 6650f24ef..90066fcb1 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -20,4 +20,5 @@ Tutor TutorialParticipant tutorial TutorialId user UserId - UniqueTutorialParticipant tutorial user \ No newline at end of file + UniqueTutorialParticipant tutorial user + deriving Eq Ord Show \ No newline at end of file diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 7b5757e94..84fd31336 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -170,6 +170,11 @@ data Transaction , transactionUser :: UserId } + | TransactionUserAssimilated + { transactionUser :: UserId + , transactionAssimilatedUser :: UserId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7db0e3c39..66061ec3e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -4,7 +4,7 @@ module Database.Esqueleto.Utils ( true, false , justVal, justValList - , isJust + , isJust, alt , isInfixOf, hasInfix , strConcat, substring , or, and @@ -30,6 +30,7 @@ module Database.Esqueleto.Utils , selectCountRows , selectMaybe , day, diffDays + , exprLift , module Database.Esqueleto.Utils.TH ) where @@ -83,6 +84,9 @@ justValList = E.valList . map Just isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing +alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) +alt a b = E.case_ [(isJust a, a), (isJust b, b)] b + infix 4 `isInfixOf`, `hasInfix` -- | Check if the first string is contained in the text derived from the second argument @@ -388,3 +392,29 @@ infixl 6 `diffDays` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) -- ^ PostgreSQL is weird. diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b + + +class ExprLift e a | e -> a where + exprLift :: a -> e + +instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where + exprLift = E.val + +instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where + exprLift f v = E.case_ + [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v') + | v' <- universeF + ] + (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + +instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where + exprLift f v1 v2 = E.case_ + [ E.when_ ( v1 E.==. E.val v1' + E.&&. v2 E.==. E.val v2' + ) + E.then_ (E.val $ f v1' v2') + | v1' <- universeF + , v2' <- universeF + ] + (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 3f479f5df..353ed4148 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -40,7 +40,6 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4) import Data.Aeson.Lens hiding (_Value, key) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index aa8f4bb50..d1c62eec5 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -37,7 +37,6 @@ import Foundation.DB import Network.Wai.Parse (lbsBackEnd) -import Control.Monad.Writer.Class (MonadWriter(..)) import UnliftIO.Pool (withResource) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 321f80691..f1c1c3a40 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -40,7 +40,6 @@ import qualified Data.Binary as Binary import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Control.Monad.Writer.Class (MonadWriter(..)) import Crypto.Hash.Conduit (sinkHash) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3c9fb713c..4c6206205 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -15,9 +15,6 @@ import qualified Network.Wai as W import qualified Data.Aeson as JSON import qualified Data.CaseInsensitive as CI -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild)) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 743bb67f2..53382e491 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -476,8 +476,6 @@ makeProfileData (Entity uid User{..}) = do examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip tutorialTable = i18n MsgPersonalInfoTutorialsWip - lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication - lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation cID <- encrypt uid mCRoute <- getCurrentRoute diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 96a285ce0..0bdc3c963 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -53,18 +53,16 @@ hijackUserForm csrf = do data UserAction = UserLdapSync | UserHijack deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe UserAction -instance Finite UserAction nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe AllUsersAction -instance Finite AllUsersAction nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllUsersAction id @@ -277,6 +275,19 @@ instance Button UniWorX ButtonAuthMode where btnClasses _ = [BCIsButton] +data UserAssimilateButton = BtnUserAssimilate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + +instance Button UniWorX UserAssimilateButton where + btnClasses _ = [BCIsButton, BCPrimary] + +nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''UserAssimilateButton id + + + + getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR = postAdminUserR postAdminUserR uuid = do @@ -393,9 +404,33 @@ postAdminUserR uuid = do | otherwise -> addMessageI Info MsgUserSystemFunctionsNotChanged redirect $ AdminUserR uuid - ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm - ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm - ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' + let assimilateForm' = renderAForm FormStandard $ + areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing + assimilateAction oldUserId = do + res <- try . runDB . setSerializable $ assimilateUser uid oldUserId + case res of + Left (err :: UserAssimilateException) -> + addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right + [whamlet| +
+ #{tshow err} + |] + Right warnings -> do + unless (null warnings) $ + addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right + [whamlet| + $newline never +