Merge branch 'test' into fradrive/lms-type-refactor

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)
 
 

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

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

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.19"
+  "version": "27.4.21"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.19",
+  "version": "27.4.21",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.19",
+  "version": "27.4.21",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.19
+version: 27.4.21
 dependencies:
   - base
   - yesod

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

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)

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)
 

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

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

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

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
+postAdminHijackUserR cID = do  
-  uid <- decrypt cID
   ((hijackRes, _), _) <- runFormPost hijackUserForm
-
+  $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
+  uid <- decrypt cID
   ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid
-
   maybe (redirect UsersR) return ret
 
 

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

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) 
+  let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock
-        | (E.Value quid, E.Value uid) <- toChange
-        , let qub = 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

src/Model/Migration/Definitions.hs

@@ -885,9 +885,7 @@ customMigrations = mapF $ \case
         |]
 
   Migration20230703LmsUserStatus ->
-    whenM (andM [ tableExists "lms_user"
+    whenM (columnNotExists "lms_user" "status_day") $ do
-                , not <$> columnExists "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)

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