From 5bb49cd88941e510a50759efaad88690f841ca47 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 18 Jul 2023 14:58:00 +0000 Subject: [PATCH 01/10] fix(build): prevent migration on non-existing table --- src/Model/Migration/Definitions.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 2ff047457..7a1d9639e 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -885,7 +885,7 @@ customMigrations = mapF $ \case |] Migration20230703LmsUserStatus -> - unlessM (columnExists "lms_user" "status_day") $ do + whenM (columnNotExists "lms_user" "status_day") $ do [executeQQ| ALTER TABLE "lms_user" ADD COLUMN "status_day" date; UPDATE "lms_user" @@ -928,3 +928,10 @@ columnExists table column = do case haveColumn :: [Single PersistValue] of [_] -> return True _other -> return False + +-- | equivalent to andM [ tableExists, not <$> columnExists] +columnNotExists :: MonadIO m + => Text -- ^ Table + -> Text -- ^ Column + -> ReaderT SqlBackend m Bool +columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column) From a25acfac058e69e21dc3ecf2fd09d8462f51d3ef Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 18 Jul 2023 15:10:41 +0000 Subject: [PATCH 02/10] chore(release): 27.4.20 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cc53ffcbd..8f439be40 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +## [27.4.20](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.19...t27.4.20) (2023-07-18) + + +### Bug Fixes + +* **build:** prevent migration on non-existing table ([5bb49cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bb49cd88941e510a50759efaad88690f841ca47)) + ## [27.4.19](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.18-2...t27.4.19) (2023-07-17) diff --git a/nix/docker/version.json b/nix/docker/version.json index 8d97e49b9..b9e227395 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.19" + "version": "27.4.20" } diff --git a/package-lock.json b/package-lock.json index 6c12a0bd5..fc15b23a9 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.19", + "version": "27.4.20", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 48e244b88..bea8350d7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.19", + "version": "27.4.20", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index dcb4189df..1b7d2904a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.19 +version: 27.4.20 dependencies: - base - yesod From 8d64ca984248bba336e639d467bdbbf56c032a22 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Jul 2023 15:33:36 +0200 Subject: [PATCH 03/10] chore(apc): remove outdate workaround --- src/Handler/PrintCenter.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 0f7d5257a..4cbd41d95 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -452,14 +452,9 @@ postPrintAckDirectR = do Right (fmap Text.strip -> reqIds) -> do -- inside conduit? let nrReq = length reqIds now <- liftIO getCurrentTime - nrApcIds <- updateWhereCount + nrOk <- updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] [PrintJobAcknowledged =. Just now] - nrOk <- if nrApcIds <= 0 && nrReq > 0 - then updateWhereCount -- for downwards compatibility only - [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just . LmsIdent . dropPrefixText "lms-" <$> reqIds)] - [PrintJobAcknowledged =. Just now] - else return nrApcIds if | nrReq <= 0 -> do let msg = "Error: No print job was acknowledged as printed, but " <> tshow nrReq <> " were requested to be, for file " <> fhead $logErrorS "APC" msg From b4ba0a30dc7c513bb9e3c567ca771d5d75de4343 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Jul 2023 13:40:12 +0000 Subject: [PATCH 04/10] fix(apc): apc cannot distinguish ij from ji, partial fix only. Needs new font --- src/Handler/Utils/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 4eeb608fe..f5f91e969 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -141,7 +141,7 @@ maxLmsUserIdentRetries = 27 randomText :: MonadIO m => String -> Int -> m Text randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range where - num_letters = ['2'..'9'] ++ ['a'..'k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these + num_letters = ['2'..'9'] ++ ['a'..'h'] ++ ['j','k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j range = extra ++ num_letters --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though From 9cf7f3965aa95f0b8f2a1574dbad90c0257edafd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Jul 2023 13:50:16 +0000 Subject: [PATCH 05/10] fix(block): negate condition to test --- src/Audit/Types.hs | 2 +- src/Handler/Utils/Qualification.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 37ba6ee4d..63455c081 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -213,7 +213,7 @@ data Transaction { transactionUser :: UserId -- qualification holder that is updated -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser , transactionQualification :: QualificationId - , transactionQualificationBlock :: QualificationUserBlock + , transactionQualificationBlock :: QualificationUserBlock -- TODO -- } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 9fd19c74f..a0c6b50e9 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -10,6 +10,8 @@ module Handler.Utils.Qualification import Import +import qualified Data.Text as Text + -- import Data.Time.Calendar (CalendarDiffDays(..)) -- import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma @@ -209,6 +211,7 @@ qualificationUserBlocking :: , Num n ) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do + $logWarnS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow reason, tshow notify] authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime -- -- Code would work, but problematic @@ -226,9 +229,10 @@ qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reas qualUser <- E.from $ E.table @QualificationUser E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids - E.&&. quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa + E.&&. quserBlock (unblock) now qualUser -- only unblock blocked qualification and vice versa -- TODO: (not unblock) <-> unblock !!!CHECK THIS ONCE MORE !!! return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) let toChange = E.unValue . fst <$> toChange' + $logWarnS "BLOCK" $ tshow toChange E.insertMany_ $ map (\quid -> QualificationUserBlock { qualificationUserBlockQualificationUser = quid , qualificationUserBlockUnblock = unblock @@ -244,7 +248,7 @@ qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reas { -- transactionQualificationUser = quid transactionQualification = qid , transactionUser = uid - , transactionQualificationBlock = error "TODO" -- CONTINUE HERE + , transactionQualificationBlock = error "TODO" -- CONTINUE HERE !!! -- } return $ fromIntegral $ length toChange From 35096ace01a2bc2a2d666794bb1ff92f52b3edec Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Jul 2023 15:21:28 +0000 Subject: [PATCH 06/10] fix(users): fix #112 and also add some convenience --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 7 +++++++ src/Handler/Profile.hs | 12 +++++++----- src/Handler/Users.hs | 19 +++++++++++++------ 6 files changed, 30 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index ff8043db6..bd12272a8 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -38,6 +38,7 @@ MenuTermShow: Jahr MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer:in MenuUserAdd: Benutzer:in anlegen +MenuUserEdit: Benutzer:in editieren MenuUserNotifications: Benachrichtigungs-Einstellungen MenuUserPassword: Passwort MenuAdminTest: Admin-Demo diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 7dc653c6a..1a7dd4dc0 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -38,6 +38,7 @@ MenuTermShow: Semesters MenuSubmissionDelete: Delete submission MenuUsers: User MenuUserAdd: Add user +MenuUserEdit: Edit user MenuUserNotifications: Notification settings MenuUserPassword: Password MenuAdminTest: Admin-demo diff --git a/routes b/routes index 7a80c2012..a0fa1e4ae 100644 --- a/routes +++ b/routes @@ -54,7 +54,7 @@ /users UsersR GET POST -- no tags, i.e. admins only /users/#CryptoUUIDUser AdminUserR GET POST /users/#CryptoUUIDUser/delete AdminUserDeleteR POST -/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation +/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 8a4dcbddd..8b74256d6 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1192,6 +1192,13 @@ pageActions (AdminUserR cID) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID + , navChildren = [] + } + , NavPageActionSecondary + { navLink = (defNavLink MsgUserHijack $ AdminHijackUserR cID){ navType = NavTypeLink { navModal = True }} + } ] pageActions InfoR = return [ NavPageActionPrimary diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a1e0d01ef..e0358449a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -376,8 +376,9 @@ validateSettings User{..} = do let pinBad = validCmdArgument =<< userPinPassword' pinMinChar = 5 pinLength = maybe 0 length userPinPassword' + pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk - guardValidation (MsgPDFPasswordTooShort pinMinChar) $ userPrefersPostal' || pinMinChar <= pinLength + guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk data ButtonResetTokens = BtnResetTokens @@ -412,6 +413,7 @@ postProfileR = requireAuthPair >>= serveProfileR serveProfileR :: (UserId, User) -> Handler Html serveProfileR (uid, user@User{..}) = do + currentRoute <- fromMaybe ProfileR <$> getCurrentRoute (userSchools, userExamOfficeLabels) <- runDB $ do userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \userSchool -> @@ -513,7 +515,7 @@ serveProfileR (uid, user@User{..}) = do , ExamOfficeLabelPriority =. examOfficeLabelPriority ] addMessageI Success MsgSettingsUpdate - redirect $ ProfileR :#: ProfileSettings + redirect $ currentRoute :#: ProfileSettings ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm @@ -521,7 +523,7 @@ serveProfileR (uid, user@User{..}) = do now <- liftIO getCurrentTime runDB $ update uid [ UserTokensIssuedAfter =. Just now ] addMessageI Info MsgTokensResetSuccess - redirect $ ProfileR :#: ProfileResetTokens + redirect $ currentRoute :#: ProfileResetTokens tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter @@ -530,7 +532,7 @@ serveProfileR (uid, user@User{..}) = do let settingsForm = wrapForm formWidget FormSettings { formMethod = POST - , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings + , formAction = Just . SomeRoute $ currentRoute :#: ProfileSettings , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit @@ -539,7 +541,7 @@ serveProfileR (uid, user@User{..}) = do tokenForm = wrapForm tokenFormWidget FormSettings { formMethod = POST - , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens + , formAction = Just . SomeRoute $ currentRoute :#: ProfileResetTokens , formEncoding = tokenEnctype , formAttrs = [] , formSubmit = FormNoSubmit diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 92f9c4803..d697feea6 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -413,15 +413,22 @@ hijackUser uid = do User{userIdent} <- runDB $ get404 uid setCredsRedirect $ Creds apDummy (CI.original userIdent) [] +getAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent +getAdminHijackUserR = postAdminHijackUserR + postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent postAdminHijackUserR cID = do uid <- decrypt cID - ((hijackRes, _), _) <- runFormPost hijackUserForm - - ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid - - maybe (redirect UsersR) return ret - + ((hijackRes, hijackWgt), hijackEnctype) <- runFormPost hijackUserForm + case hijackRes of + (FormSuccess ()) -> hijackUser uid + _ -> selectRep $ do + provideRep . siteLayoutMsg MsgUserHijack $ do + setTitleI MsgUserHijack + let hjForm = wrapForm hijackWgt def{ formEncoding = hijackEnctype } + [whamlet| + ^{hjForm} + |] data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) From 88bf21c9c5de3755ea6591c97dc1f99a928914d5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jul 2023 08:55:12 +0000 Subject: [PATCH 07/10] fix(users): fix #112 working now --- src/Foundation/Navigation.hs | 13 +++++++++++-- src/Handler/Users.hs | 31 ++++++++++++++++++------------- 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 8b74256d6..9f4ef54bd 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -442,6 +442,14 @@ defNavLink navLabel navRoute = NavLink {..} navQuick' = mempty navForceActive = False +defNavLinkModal :: (RenderMessage UniWorX msg, HasRoute UniWorX route) => msg -> route -> NavLink +defNavLinkModal navLabel navRoute = NavLink {..} + where + navAccess' = NavAccessTrue + navType = NavTypeLink { navModal = True} + navQuick' = mempty + navForceActive = False + navBaseRoute :: NavLink -> Route UniWorX navBaseRoute NavLink{navRoute} = urlRoute navRoute @@ -1196,8 +1204,9 @@ pageActions (AdminUserR cID) = return { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID , navChildren = [] } - , NavPageActionSecondary - { navLink = (defNavLink MsgUserHijack $ AdminHijackUserR cID){ navType = NavTypeLink { navModal = True }} + , NavPageActionPrimary + { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID + , navChildren = [] } ] pageActions InfoR = return diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d697feea6..23ca1e78d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -413,22 +413,27 @@ hijackUser uid = do User{userIdent} <- runDB $ get404 uid setCredsRedirect $ Creds apDummy (CI.original userIdent) [] -getAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent -getAdminHijackUserR = postAdminHijackUserR +getAdminHijackUserR :: CryptoUUIDUser -> Handler Html +getAdminHijackUserR cID = do + (hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm + let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID } + uid :: UserId <- decrypt cID + usr <- runDB $ get404 uid + siteLayoutMsg MsgUserHijack $ do + setTitleI MsgUserHijack + [whamlet| + ^{userWidget usr} + ^{hjForm} + |] postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent -postAdminHijackUserR cID = do +postAdminHijackUserR cID = do + ((hijackRes, _), _) <- runFormPost hijackUserForm + $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes uid <- decrypt cID - ((hijackRes, hijackWgt), hijackEnctype) <- runFormPost hijackUserForm - case hijackRes of - (FormSuccess ()) -> hijackUser uid - _ -> selectRep $ do - provideRep . siteLayoutMsg MsgUserHijack $ do - setTitleI MsgUserHijack - let hjForm = wrapForm hijackWgt def{ formEncoding = hijackEnctype } - [whamlet| - ^{hjForm} - |] + ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid + maybe (redirect UsersR) return ret + data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) From 6cec571341f3200fed29987b4b5a1992f2310655 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jul 2023 08:55:48 +0000 Subject: [PATCH 08/10] chore(audit): confine audit log messages to a single long line --- src/Audit.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Audit.hs b/src/Audit.hs index c6b7c7dfd..b6b8012a0 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -17,6 +17,7 @@ import Model import Database.Persist.Sql import Audit.Types +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Utils.Lens @@ -110,4 +111,4 @@ audit transaction@(toJSON -> transactionLogInfo) = do insert_ TransactionLog{..} - $logInfoS "Audit" $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> "\n" <> pack (prettyCallStack callStack) + $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack) From 5397c7be353fc1b1e8310f66b49a9b93ee890253 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jul 2023 08:59:08 +0000 Subject: [PATCH 09/10] fix(qualification): new block/unblock mechanism working now --- src/Handler/Utils/Qualification.hs | 35 +++++++++++++++--------------- test/Database/Fill.hs | 2 +- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a0c6b50e9..9d0c6836b 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -218,39 +218,40 @@ qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reas -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid - -- E.&&. quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa + -- E.&&. quserBlock unblock nowaday qualificationUser -- only unblock blocked qualification and vice versa -- return $ QualificationUserBlock -- E.<# qualificationUser E.^. QualificationUserId -- E.<&> E.val unblock -- E.<&> E.val nowaday -- E.<&> E.val reason -- E.<&> E.val authUsr - toChange' <- E.select $ do + toChange <- E.select $ do qualUser <- E.from $ E.table @QualificationUser E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids - E.&&. quserBlock (unblock) now qualUser -- only unblock blocked qualification and vice versa -- TODO: (not unblock) <-> unblock !!!CHECK THIS ONCE MORE !!! - return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) - let toChange = E.unValue . fst <$> toChange' - $logWarnS "BLOCK" $ tshow toChange - E.insertMany_ $ map (\quid -> QualificationUserBlock - { qualificationUserBlockQualificationUser = quid - , qualificationUserBlockUnblock = unblock - , qualificationUserBlockFrom = now - , qualificationUserBlockReason = reason - , qualificationUserBlockBlocker = authUsr - }) toChange + E.&&. quserBlock unblock now qualUser -- only unblock blocked qualification and vice versa + return (qualUser E.^. QualificationUserUser, qualUser E.^. QualificationUserId) + -- $logInfoS "BLOCK" $ tshow toChange - unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now] + let changes :: [(UserId, QualificationUserBlock)] = map (\(E.Value uid, E.Value quid) -> (uid, QualificationUserBlock + { qualificationUserBlockQualificationUser = quid + , qualificationUserBlockUnblock = unblock + , qualificationUserBlockFrom = now + , qualificationUserBlockReason = reason + , qualificationUserBlockBlocker = authUsr + }) + ) toChange + E.insertMany_ (map snd changes) + unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> changes)] [QualificationUserLastNotified =. now] - forM_ toChange' $ \(_, E.Value uid) -> do + forM_ changes $ \(uid, qub) -> do audit TransactionQualificationUserBlocking { -- transactionQualificationUser = quid transactionQualification = qid , transactionUser = uid - , transactionQualificationBlock = error "TODO" -- CONTINUE HERE !!! -- + , transactionQualificationBlock = qub } - return $ fromIntegral $ length toChange + return $ fromIntegral $ length changes qualificationUserUnblockByReason :: diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 03c7ee385..7a70451e3 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -724,7 +724,7 @@ fillDb = do qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal) <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser] - insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- take 200 matUsers, uid `Set.notMember` qidfUsers] void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now From 9131d99fa3000fd279b77b98482d91010cdc7b34 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jul 2023 09:01:19 +0000 Subject: [PATCH 10/10] chore(release): 27.4.21 --- CHANGELOG.md | 11 +++++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 15 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8f439be40..2255558f4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ 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. +## [27.4.21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.20...t27.4.21) (2023-07-26) + + +### Bug Fixes + +* **apc:** apc cannot distinguish ij from ji, partial fix only. Needs new font ([b4ba0a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4ba0a30dc7c513bb9e3c567ca771d5d75de4343)) +* **block:** negate condition to test ([9cf7f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9cf7f3965aa95f0b8f2a1574dbad90c0257edafd)) +* **qualification:** new block/unblock mechanism working now ([5397c7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5397c7be353fc1b1e8310f66b49a9b93ee890253)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) and also add some convenience ([35096ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35096ace01a2bc2a2d666794bb1ff92f52b3edec)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) working now ([88bf21c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88bf21c9c5de3755ea6591c97dc1f99a928914d5)) + ## [27.4.20](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.19...t27.4.20) (2023-07-18) diff --git a/nix/docker/version.json b/nix/docker/version.json index b9e227395..536736a22 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.20" + "version": "27.4.21" } diff --git a/package-lock.json b/package-lock.json index fc15b23a9..952a40038 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.20", + "version": "27.4.21", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index bea8350d7..3b5c590e0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.20", + "version": "27.4.21", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1b7d2904a..e5c9a8e44 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.20 +version: 27.4.21 dependencies: - base - yesod