diff --git a/CHANGELOG.md b/CHANGELOG.md index cc53ffcbd..2255558f4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,24 @@ 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) + + +### 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/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 548508ef4..816b57995 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 c9799daa9..3bc54feeb 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/nix/docker/version.json b/nix/docker/version.json index 8d97e49b9..536736a22 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.19" + "version": "27.4.21" } diff --git a/package-lock.json b/package-lock.json index 6c12a0bd5..952a40038 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.19", + "version": "27.4.21", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 48e244b88..3b5c590e0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.19", + "version": "27.4.21", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index dcb4189df..e5c9a8e44 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.19 +version: 27.4.21 dependencies: - base - yesod diff --git a/routes b/routes index f9bdd053b..b47c2c3b9 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/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) 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/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index cf3449c13..a43d59f5a 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -451,6 +451,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 @@ -1201,6 +1209,14 @@ pageActions (AdminUserR cID) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID + , navChildren = [] + } ] pageActions InfoR = return [ NavPageActionPrimary 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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index bd1762c95..5c2acdd0a 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..23ca1e78d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -413,13 +413,25 @@ hijackUser uid = do User{userIdent} <- runDB $ get404 uid setCredsRedirect $ Creds apDummy (CI.original userIdent) [] +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 - uid <- decrypt cID +postAdminHijackUserR cID = do ((hijackRes, _), _) <- runFormPost hijackUserForm - + $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes + uid <- decrypt cID ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid - maybe (redirect UsersR) return ret diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index b93c832ba..f8de8e5de 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -165,7 +165,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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a3eabff86..29582581c 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -11,6 +11,7 @@ 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 @@ -229,7 +230,7 @@ qualificationUserBlocking :: , Num n ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do - $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow reason, tshow notify] + $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify] authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime let blockTime = fromMaybe now mbBlockTime @@ -250,16 +251,13 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) - let newBlocks = [ (uid, qub) - | (E.Value quid, E.Value uid) <- toChange - , let qub = QualificationUserBlock + let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock { qualificationUserBlockQualificationUser = quid , qualificationUserBlockUnblock = unblock , qualificationUserBlockFrom = blockTime , qualificationUserBlockReason = reason , qualificationUserBlockBlocker = authUsr - } - ] + })) toChange E.insertMany_ (snd <$> newBlocks) unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now] forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 55c4a031b..cbb5c548b 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -885,9 +885,7 @@ customMigrations = mapF $ \case |] Migration20230703LmsUserStatus -> - whenM (andM [ tableExists "lms_user" - , not <$> 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" @@ -930,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) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d8b55b837..3cfa94f8a 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