Merge branch 'test' into fradrive/lms-type-refactor
This commit is contained in:
commit
c6f2b21927
18
CHANGELOG.md
18
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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.19"
|
||||
"version": "27.4.21"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.19",
|
||||
"version": "27.4.21",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.19",
|
||||
"version": "27.4.21",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.19
|
||||
version: 27.4.21
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
2
routes
2
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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user