From d0befa9ce27db8bbdb511f567dde713beca28f37 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 24 Jan 2020 13:38:02 +0100 Subject: [PATCH 01/31] chore: fix slow build through tooling update --- nixpkgs.nix | 4 ++-- shell.nix | 2 +- start.sh | 4 +++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/nixpkgs.nix b/nixpkgs.nix index 783ede000..1d0131f12 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,6 +4,6 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf"; - sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm"; + rev = "0d97ef510bdc9d66f1023f970be58fdab2eb87fa"; + sha256 = "00lnna6097wzrlmwqk8bqayh4qd2gz61zcd4yh7amirqflz3z2ll"; }) diff --git a/shell.nix b/shell.nix index 08c6dde7c..9a3306edc 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" diff --git a/start.sh b/start.sh index 49f9e79f3..07cf5940a 100755 --- a/start.sh +++ b/start.sh @@ -25,4 +25,6 @@ if [[ -d .stack-work-run ]]; then trap move-back EXIT fi -stack exec -- yesod devel $@ +# stack exec -- yesod devel $@ + +yesod devel $@ From a7b7bdbea754873e11fea8d2af42bf3aacaff3f2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 28 Jan 2020 16:15:18 +0100 Subject: [PATCH 02/31] fix: submission user notification recipients for pseudonym subs --- src/Handler/Corrections.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index df5aad3eb..9fb3215e8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -953,7 +953,7 @@ postCorrectionsCreateR = do , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated uid subId + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (genericLength spGroup > maxSize) $ addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc @@ -998,7 +998,7 @@ postCorrectionsCreateR = do , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated uid subId + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (length spGroup > 1) $ addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc From 282df86bc20b5ec884379c6c81f232abfb4631c3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 17:36:22 +0200 Subject: [PATCH 03/31] feat(exam): start work on automatic exam-occurrence assignment --- src/Handler/Utils/Exam.hs | 157 +++++++++++++++++++++++++++++++++++++- src/Model/Types/Exam.hs | 13 ++++ 2 files changed, 169 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index dd9742e39..d3cdd4278 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -3,9 +3,10 @@ module Handler.Utils.Exam , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade + , examAutoOccurrence ) where -import Import.NoFoundation +import Import.NoFoundation hiding (distribute) import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E @@ -16,8 +17,16 @@ import Database.Esqueleto.Utils.TH import qualified Data.Conduit.List as C import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Fixed (Fixed(..)) +import qualified Data.Foldable as F + +import qualified Data.CaseInsensitive as CI + +import Control.Monad.Trans.Random.Lazy (evalRand) +import System.Random (mkStdGen) +import Control.Monad.Random.Class (uniform) fetchExamAux :: ( SqlBackendCanRead backend @@ -161,3 +170,149 @@ examGrade Exam{..} mBonus (otoList -> results) lowerBounds :: [(ExamGrade, Points)] lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' + +examAutoOccurrence :: forall seed. + Hashable seed + => seed + -> ExamOccurrenceRule + -> Map ExamOccurrenceId Natural + -> Map UserId (User, Maybe ExamOccurrenceId) + -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) +examAutoOccurrence (hash -> seed) rule occurrences users + | sum occurrences < fromIntegral (Map.size users) + || Map.null users + = nullResult + | otherwise + = case rule of + ExamRoomRandom + -> ( Nothing + , flip Map.mapWithKey users $ \uid (_, mOcc) + -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ + uniform $ Map.keysSet occurrences + in Just $ fromMaybe randomOcc mOcc + ) + _ | Just (postprocess -> (resMapping, result)) <- bestOption + -> ( Just $ ExamOccurrenceMapping rule resMapping + , Map.unionWith (<|>) (view _2 <$> users) result + ) + _ -> nullResult + where + nullResult = (Nothing, view _2 <$> users) + + users' :: Map [CI Char] (Set UserId) + -- ^ Finest partition of users + users' = case rule of + ExamRoomSurname + -> Map.fromListWith Set.union + [ (map CI.mk $ unpack userSurname, Set.singleton uid) + | (uid, (User{..}, Nothing)) <- Map.toList users + , not $ null userSurname + ] + ExamRoomMatriculation + -> let matrUsers + = Map.fromListWith Set.union + [ (map CI.mk . reverse $ unpack matriculation, Set.singleton uid) + | (uid, (User{..}, Nothing)) <- Map.toList users + , let Just matriculation = userMatrikelnummer + , not $ null matriculation + ] + in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers + _ -> Map.singleton [] $ Map.keysSet users + + usersGroups :: Natural -- ^ fineness + -> Map [CI Char] (Set UserId) + -- ^ Partition users into monotonously finer partitions + usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users' + + maximumFineness :: Natural + -- ^ Fineness at which `usersGroups` becomes constant + maximumFineness = fromIntegral . F.maximum . Set.map length $ Map.keysSet users' + + occurrences' :: [(ExamOccurrenceId, Natural)] + -- ^ Minimise number of occurrences used + -- + -- Prefer occurrences with higher capacity + -- + -- If a single occurrence can accomodate all participants, pick the one with + -- the least capacity + occurrences' + | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences + = pure $ minimumBy (comparing $ view _2) largeEnoughs + | otherwise + = view _2 . foldr accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences + where + usersCount = fromIntegral $ Map.size users + + accF :: (ExamOccurrenceId, Natural) + -> (Natural, [(ExamOccurrenceId, Natural)]) + -> (Natural, [(ExamOccurrenceId, Natural)]) + accF occ@(_, occSize) acc@(accSize, accOccs) + | accSize >= usersCount + = acc + | otherwise + = ( accSize + occSize + , accOccs ++ [occ] + ) + + largestOccurrence :: Num a => a + largestOccurrence = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull occurrences' + + finenessCost :: Natural -> Natural + finenessCost x = round (finenessConst * largestOccurrence) * fromIntegral (length occurrences') * x * x + where + finenessConst :: Rational + -- ^ Cost (scaled to proportion of occurrence) of having higher fineness + finenessConst = 1 % 20 -- TODO: tweak + + + distribute :: forall wordId lineId cost. + ( Num cost + , Ord wordId, Ord lineId + ) + => [(wordId, Natural)] + -> [(lineId, Natural)] + -> Maybe (cost, Map lineId (Set wordId)) + -- ^ Distribute the given items (@wordId@s) with associated size in + -- contiguous blocks into the given buckets (@lineId@s) such that they are + -- filled as evenly as possible (proportionally) + -- + -- Return a cost scaled to item-size squared + -- + -- See under \"Shortest Path\" + distribute wordLengths lineLengths + | null wordLengths = Just (0, Map.empty) + | null lineLengths = Nothing + | otherwise = Just distribute' + where + _longestLine :: cost + -- ^ For scaling costs + _longestLine = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull lineLengths + + distribute' = error "not implemented" -- TODO: implement + + + options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))] + options = do + fineness <- [0..maximumFineness] + let + packets :: [([CI Char], Natural)] + packets = Map.toAscList . fmap (fromIntegral . Set.size) $ usersGroups fineness + (resultCost, result) <- hoistMaybe $ distribute packets occurrences' + return (fineness, (resultCost, result)) + bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char])) + bestOption = options + & takeWhile (\(fineness, (resCost, _)) -> finenessCost fineness < resCost) + & map (view $ _2 . _2) + & fmap last . fromNullable + + postprocess :: Map ExamOccurrenceId (Set [CI Char]) + -> ( [(ExamOccurrenceId, [CI Char])] + , Map UserId (Maybe ExamOccurrenceId) + ) + postprocess result = (resultAscList, resultUsers) + where + resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result + resultUsers = Map.fromList $ do + (occId, buckets) <- Map.toList result + user <- Set.toList $ foldMap (flip (Map.findWithDefault Set.empty) users') buckets + return (user, Just occId) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 7e7ce52bc..e6186c2b0 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -11,6 +11,7 @@ module Model.Types.Exam , _examResult , ExamBonusRule(..) , ExamOccurrenceRule(..) + , ExamOccurrenceMapping(..) , ExamGrade(..) , numberGrade , ExamGradeDefCenter(..) @@ -152,6 +153,18 @@ deriveJSON defaultOptions } ''ExamOccurrenceRule derivePersistFieldJSON ''ExamOccurrenceRule +data ExamOccurrenceMapping roomId = ExamOccurrenceMapping + { examOccurrenceMappingRule :: ExamOccurrenceRule + , examOccurrenceMappingMapping :: [(roomId, [CI Char])] + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } ''ExamOccurrenceMapping +derivePersistFieldJSON ''ExamOccurrenceMapping + + data ExamGrade = Grade50 | Grade40 From f89545f36ec4b0d45a0607b04d4b0d86b5dd1caa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 23 Sep 2019 08:55:47 +0200 Subject: [PATCH 04/31] feat(exam): working prototype of automatic occurrence assignment --- package.yaml | 1 + src/Handler/Utils/Exam.hs | 173 ++++++++++++++++++++++++++++++++------ stack.yaml | 2 + test/TestImport.hs | 33 +------- test/User.hs | 40 +++++++++ 5 files changed, 191 insertions(+), 58 deletions(-) create mode 100644 test/User.hs diff --git a/package.yaml b/package.yaml index e2e15ec82..f8d437c20 100644 --- a/package.yaml +++ b/package.yaml @@ -137,6 +137,7 @@ dependencies: - prometheus-client - prometheus-metrics-ghc - wai-middleware-prometheus + - extended-reals other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index d3cdd4278..f4d1d32d9 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -26,7 +26,22 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Random.Lazy (evalRand) import System.Random (mkStdGen) -import Control.Monad.Random.Class (uniform) +import Control.Monad.Random.Class (weightedMay) +import Control.Monad.ST (ST, runST) + +import Data.Array (Array) +import qualified Data.Array as Array + +import Data.Array.ST (STArray, STUArray) +import qualified Data.Array.ST as ST + +import Data.List (findIndex, unfoldr) +import qualified Data.List as List + +import Data.ExtendedReal + +import qualified Data.Text as Text +import qualified Data.Char as Char fetchExamAux :: ( SqlBackendCanRead backend @@ -179,7 +194,7 @@ examAutoOccurrence :: forall seed. -> Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) examAutoOccurrence (hash -> seed) rule occurrences users - | sum occurrences < fromIntegral (Map.size users) + | sum occurrences < usersCount || Map.null users = nullResult | otherwise @@ -188,8 +203,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -> ( Nothing , flip Map.mapWithKey users $ \uid (_, mOcc) -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ - uniform $ Map.keysSet occurrences - in Just $ fromMaybe randomOcc mOcc + weightedMay $ over _2 fromIntegral <$> occurrences' + in mOcc <|> randomOcc ) _ | Just (postprocess -> (resMapping, result)) <- bestOption -> ( Just $ ExamOccurrenceMapping rule resMapping @@ -198,31 +213,42 @@ examAutoOccurrence (hash -> seed) rule occurrences users _ -> nullResult where nullResult = (Nothing, view _2 <$> users) - + usersCount :: forall a. Num a => a + usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' + users' :: Map [CI Char] (Set UserId) -- ^ Finest partition of users users' = case rule of ExamRoomSurname -> Map.fromListWith Set.union - [ (map CI.mk $ unpack userSurname, Set.singleton uid) + [ (map CI.mk $ unpack userSurname', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , not $ null userSurname + , let userSurname' = Text.filter Char.isLetter userSurname + , not $ null userSurname' ] ExamRoomMatriculation -> let matrUsers = Map.fromListWith Set.union - [ (map CI.mk . reverse $ unpack matriculation, Set.singleton uid) + [ (map CI.mk $ unpack matriculation', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let Just matriculation = userMatrikelnummer - , not $ null matriculation + , let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer + , not $ null matriculation' ] in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers _ -> Map.singleton [] $ Map.keysSet users usersGroups :: Natural -- ^ fineness -> Map [CI Char] (Set UserId) - -- ^ Partition users into monotonously finer partitions - usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users' + -- ^ Partition users into monotonously finer + usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union restr users' + where + restr = case rule of + ExamRoomSurname + -> take c + ExamRoomMatriculation + -> reverse . take c . reverse + _other + -> id maximumFineness :: Natural -- ^ Fineness at which `usersGroups` becomes constant @@ -239,19 +265,17 @@ examAutoOccurrence (hash -> seed) rule occurrences users | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences = pure $ minimumBy (comparing $ view _2) largeEnoughs | otherwise - = view _2 . foldr accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences + = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences where - usersCount = fromIntegral $ Map.size users - - accF :: (ExamOccurrenceId, Natural) + accF :: (Natural, [(ExamOccurrenceId, Natural)]) + -> (ExamOccurrenceId, Natural) -> (Natural, [(ExamOccurrenceId, Natural)]) - -> (Natural, [(ExamOccurrenceId, Natural)]) - accF occ@(_, occSize) acc@(accSize, accOccs) + accF acc@(accSize, accOccs) occ@(_, occSize) | accSize >= usersCount = acc | otherwise = ( accSize + occSize - , accOccs ++ [occ] + , occ : accOccs ) largestOccurrence :: Num a => a @@ -262,7 +286,7 @@ examAutoOccurrence (hash -> seed) rule occurrences users where finenessConst :: Rational -- ^ Cost (scaled to proportion of occurrence) of having higher fineness - finenessConst = 1 % 20 -- TODO: tweak + finenessConst = 1 % 5 -- TODO: tweak distribute :: forall wordId lineId cost. @@ -282,26 +306,121 @@ examAutoOccurrence (hash -> seed) rule occurrences users distribute wordLengths lineLengths | null wordLengths = Just (0, Map.empty) | null lineLengths = Nothing - | otherwise = Just distribute' + | otherwise = let (cost, result) = distribute' + in case cost of + Finite c -> Just (fromInteger $ round c, result) + _other -> Nothing where - _longestLine :: cost + longestLine :: Natural -- ^ For scaling costs - _longestLine = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull lineLengths + longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths - distribute' = error "not implemented" -- TODO: implement + wordMap :: Map wordId Natural + wordMap = Map.fromListWith (+) wordLengths + + wordIx :: Iso' wordId Int + wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords + in ix' + ) + (collapsedWords Array.!) + + collapsedWords :: Array Int wordId + collapsedWords = Array.array + (0, pred $ Map.size wordMap) + [ (ix', wId) + | wId <- Map.keys wordMap + , let Just ix' = findIndex ((== wId) . view _1) wordLengths + ] + + offsets :: Array Int Natural + offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0) + where + accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int)) + accOffsets accSize ix' + | ix' <= 0 = Just (0, (0, 1)) + | Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix') + in Just (newSize, (newSize, succ ix')) + | otherwise = Nothing + + bounds = (0, Map.size wordMap) + + distribute' :: (Extended Rational, Map lineId (Set wordId)) + distribute' = runST $ do + minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) + breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) + + forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do + let go i j + | j <= Map.size wordMap = do + let + walkBack 0 = return 0 + walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' + lineIx <- walkBack i + let potWidth + | lineIx >= 0 + , lineIx < length lineLengths + = view _2 $ lineLengths List.!! lineIx + | otherwise + = 0 + w = offsets Array.! j - offsets Array.! i + cost <- (+) (widthCost potWidth w) <$> ST.readArray minima i + when (isFinite cost) $ do + minCost <- ST.readArray minima j + when (cost < minCost) $ do + ST.writeArray minima j cost + ST.writeArray breaks j i + go i' $ succ j + | otherwise = return () + in go i' $ succ i' + traceM . show =<< ST.getElems breaks + + let accumResult lineIx j (accCost, accMap) = do + i <- ST.readArray breaks j + accCost' <- (+) accCost <$> ST.readArray minima j + traceM $ show (accCost', lineIx, [i .. pred j]) + let accMap' = Map.insertWith Set.union (lineIxs List.!! lineIx) (Set.fromList $ map (review wordIx) [i .. pred j]) accMap + if + | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') + | otherwise -> return (accCost', accMap') + lineIxs = reverse $ map (view _1) lineLengths + in accumResult 0 (Map.size wordMap) (0, Map.empty) + + + widthCost :: Natural -> Natural -> Extended Rational + widthCost lineWidth w + | lineWidth < w = PosInf + | otherwise = Finite (((fromIntegral lineWidth % fromIntegral w) - optimumRatio) * fromIntegral longestLine) ^ 2 + where + optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) lineLengths) (map (view _2) wordLengths) options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))] options = do fineness <- [0..maximumFineness] + + let usersGroups' = fromIntegral . Set.size <$> usersGroups fineness + + traceM $ show usersGroups' + traceM . show $ map snd occurrences' + + -- The algorithm used in `distribute` produces no usable result if the + -- situation occurs, that a single item does not fit within a bucket. + -- In a naive attempt to prevent this we ensure that all items fit into + -- all buckets. + guard . (\(fromIntegral -> maxSize) -> all ((>= maxSize) . view _2) occurrences') . maybe 0 maximum $ fromNullable usersGroups' + let packets :: [([CI Char], Natural)] - packets = Map.toAscList . fmap (fromIntegral . Set.size) $ usersGroups fineness + packets = Map.toAscList usersGroups' (resultCost, result) <- hoistMaybe $ distribute packets occurrences' + + traceM $ show (fineness, finenessCost fineness, resultCost) + traceM . show . map (foldMap $ \prefix -> Sum $ usersGroups' Map.! prefix) $ Map.elems result + return (fineness, (resultCost, result)) bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char])) bestOption = options - & takeWhile (\(fineness, (resCost, _)) -> finenessCost fineness < resCost) + & over _tail (takeWhile $ \(fineness, (resCost, _)) -> finenessCost fineness <= resCost) & map (view $ _2 . _2) & fmap last . fromNullable @@ -314,5 +433,5 @@ examAutoOccurrence (hash -> seed) rule occurrences users resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result resultUsers = Map.fromList $ do (occId, buckets) <- Map.toList result - user <- Set.toList $ foldMap (flip (Map.findWithDefault Set.empty) users') buckets + user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b `List.isPrefixOf` b') $ Map.toList users') buckets return (user, Just occId) diff --git a/stack.yaml b/stack.yaml index 2764abce4..d0852e051 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,5 +67,7 @@ extra-deps: - prometheus-metrics-ghc-1.0.0 - wai-middleware-prometheus-1.0.0 + - extended-reals-0.2.3.0 + resolver: lts-13.21 allow-newer: true diff --git a/test/TestImport.hs b/test/TestImport.hs index 2b13743ab..9106ec67e 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -47,6 +47,7 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) +import User as X (fakeUser) import Control.Monad.Catch as X hiding (Handler(..)) @@ -118,37 +119,7 @@ authenticateAs (Entity _ User{..}) = do -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. createUser :: (User -> User) -> YesodExample UniWorX (Entity User) -createUser adjUser = do - UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod - now <- liftIO getCurrentTime - let - userMatrikelnummer = Nothing - userAuthentication = AuthLDAP - userLastAuthentication = Nothing - userTokensIssuedAfter = Nothing - userIdent = "dummy@example.invalid" - userEmail = "dummy@example.invalid" - userDisplayEmail = "dummy@example.invalid" - userDisplayName = "Dummy Example" - userSurname = "Example" - userFirstName = "Dummy" - userTitle = Nothing - userTheme = userDefaultTheme - userMaxFavourites = userDefaultMaxFavourites - userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - userDateTimeFormat = userDefaultDateTimeFormat - userDateFormat = userDefaultDateFormat - userTimeFormat = userDefaultTimeFormat - userDownloadFiles = userDefaultDownloadFiles - userWarningDays = userDefaultWarningDays - userShowSex = userDefaultShowSex - userLanguages = Nothing - userNotificationSettings = def - userCreated = now - userLastLdapSynchronisation = Nothing - userCsvOptions = def - userSex = Nothing - runDB . insertEntity $ adjUser User{..} +createUser = runDB . insertEntity . fakeUser lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p)) diff --git a/test/User.hs b/test/User.hs new file mode 100644 index 000000000..1efb8d673 --- /dev/null +++ b/test/User.hs @@ -0,0 +1,40 @@ +module User + ( fakeUser + ) where + +import ClassyPrelude + +import Settings +import Model + +import Data.Default +import System.IO.Unsafe + + +fakeUser :: (User -> User) -> User +fakeUser adjUser = adjUser User{..} + where + UserDefaultConf{..} = appUserDefaults compileTimeAppSettings + + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userLastAuthentication = Nothing + userTokensIssuedAfter = Nothing + userIdent = "dummy@example.invalid" + userEmail = "dummy@example.invalid" + userDisplayEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userFirstName = "Dummy" + userTitle = Nothing + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + userWarningDays = userDefaultWarningDays + userMailLanguages = def + userNotificationSettings = def + userCreated = unsafePerformIO getCurrentTime + userLastLdapSynchronisation = Nothing From e994fafe28a32022c06c2cce123181525061f24e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 20:31:37 +0100 Subject: [PATCH 05/31] feat(exams): automatic exam occurrence assignment --- ghci.sh | 2 +- messages/uniworx/de-de-formal.msg | 16 +- messages/uniworx/en-eu.msg | 2 +- models/exams.model | 1 + package.yaml | 3 + routes | 1 + src/Database/Persist/Class/Instances.hs | 9 +- src/Foundation.hs | 1 + src/Handler/Exam.hs | 1 + src/Handler/Exam/AutoOccurrence.hs | 137 +++++++++++ src/Handler/Exam/Edit.hs | 1 + src/Handler/Exam/New.hs | 1 + src/Handler/Exam/Show.hs | 4 + src/Handler/Exam/Users.hs | 4 +- src/Handler/Utils/Exam.hs | 224 +++++++++++------- src/Handler/Utils/Widgets.hs | 13 + src/Model.hs | 6 + src/Model/Types/Exam.hs | 56 ++++- src/Utils/Form.hs | 1 + stack.yaml.lock | 7 + templates/exam-show.hamlet | 20 ++ templates/exam-users.hamlet | 3 + templates/exam/auto-occurrence-confirm.hamlet | 3 + ...exam-occurrence-mapping-description.hamlet | 15 ++ .../widgets/exam-occurrence-mapping.hamlet | 41 ++++ test/Database.hs | 1 + 26 files changed, 480 insertions(+), 93 deletions(-) create mode 100644 src/Handler/Exam/AutoOccurrence.hs create mode 100644 templates/exam/auto-occurrence-confirm.hamlet create mode 100644 templates/widgets/exam-occurrence-mapping-description.hamlet create mode 100644 templates/widgets/exam-occurrence-mapping.hamlet diff --git a/ghci.sh b/ghci.sh index ab5cf41bd..750d384b8 100755 --- a/ghci.sh +++ b/ghci.sh @@ -20,4 +20,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib} +stack ghci --flag uniworx:dev --flag uniworx:library-only --ghci-options -fobject-code ${@:-uniworx:lib} diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 81bbd36ff..f31a52272 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1267,6 +1267,7 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste +BreadcrumbExamAutoOccurrence: Automatische Raumverteilung ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -1574,7 +1575,7 @@ ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positi ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. ExamAutomaticOccurrenceAssignment: Termin- bzw. Raumzuteilung -ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Die automatische Verteilung muss von einem Kursverwalter ausgelöst werden und geschieht nicht mit Ablauf einer Frist o.Ä.. Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist somit immer möglich. ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung @@ -2270,4 +2271,15 @@ ExternalExamUserMustBeStaff: Sie selbst müssen stets assoziierte Person sein, f ExternalExamCourseExists: Der angegebene Kurs existiert im System. Prüfungen sollten daher direkt beim Kurs (statt extern) hinterlegt werden. ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ existiert bereits. ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt. -ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. \ No newline at end of file +ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. + +ExamAutoOccurrenceMinimizeRooms: Verwendete Räume minimieren +ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? +ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert +ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen +TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid}-#{ssh}-#{csh} #{examn}: Automatische Raumverteilung +BtnExamAutoOccurrenceCalculate: Verteilung berechnen +BtnExamAutoOccurrenceAccept: Verteilung akzeptieren +ExamRoomMappingSurname: Nachnamen beginnend mit +ExamRoomMappingMatriculation: Matrikelnummern endend in +ExamRoomLoad: Auslastung \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index cfac175fd..1f697b94d 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1572,7 +1572,7 @@ ExamBonusRoundNonPositive: Rounding multiple must be positive and greater than z ExamBonusRoundTip: Bonus points are rounded commercially to a multiple of the given number ExamAutomaticOccurrenceAssignment: Selection of occurrences/rooms for/by participants -ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/a room, or should they be assigned to occurrences/rooms manually by course administrators? Manipulation of the distribution and manually assigning participants remains possible. +ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/room, or should they be assigned to occurrences/rooms manually by course administrators? Automatic distribution needs to be triggered by a course administrator. It is not done automatically at a predefined time. Thus manipulation of the distribution and manually assigning participants remains possible. ExamOccurrenceRule: Procedure ExamOccurrenceRuleParticipant: Occurrence/room assignment procedure ExamRoomManual': No automatic or autonomous assignment diff --git a/models/exams.model b/models/exams.model index 5baa6e711..2bdc42cda 100644 --- a/models/exams.model +++ b/models/exams.model @@ -4,6 +4,7 @@ Exam gradingRule ExamGradingRule Maybe bonusRule ExamBonusRule Maybe occurrenceRule ExamOccurrenceRule + examOccurrenceMapping (ExamOccurrenceMapping ExamOccurrenceName) Maybe visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/package.yaml b/package.yaml index f8d437c20..86e2ff3c8 100644 --- a/package.yaml +++ b/package.yaml @@ -138,6 +138,7 @@ dependencies: - prometheus-metrics-ghc - wai-middleware-prometheus - extended-reals + - rfc5051 other-extensions: - GeneralizedNewtypeDeriving @@ -182,6 +183,8 @@ default-extensions: - DeriveGeneric - DeriveLift - DeriveFunctor + - DeriveFoldable + - DeriveTraversable - DerivingStrategies - DerivingVia - DataKinds diff --git a/routes b/routes index 8bf60981c..52f9bad23 100644 --- a/routes +++ b/routes @@ -188,6 +188,7 @@ /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result /register/#ExamOccurrenceName ERegisterOccR POST !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result /grades EGradesR GET POST !exam-office + /assign-occurrences EAutoOccurrenceR POST /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 8fc9eb20b..193ea1f16 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-} module Database.Persist.Class.Instances ( @@ -10,12 +10,15 @@ import ClassyPrelude import Database.Persist.Class import Database.Persist.Types (HaskellName, DBName, PersistValue) import Database.Persist.Types.Instances () +import Database.Persist.Sql import Data.Binary (Binary) import qualified Data.Binary as Binary import qualified Data.Map as Map +import Data.Aeson (ToJSONKey, FromJSONKey) + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -34,3 +37,7 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap + + +deriving newtype instance ToJSONKey (BackendKey SqlBackend) +deriving newtype instance FromJSONKey (BackendKey SqlBackend) diff --git a/src/Foundation.hs b/src/Foundation.hs index a4d40b60e..184cedf7c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1923,6 +1923,7 @@ instance YesodBreadcrumbs UniWorX where EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 6580c90f4..ca916130c 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -11,3 +11,4 @@ import Handler.Exam.Edit as Handler.Exam import Handler.Exam.Show as Handler.Exam import Handler.Exam.Users as Handler.Exam import Handler.Exam.AddUser as Handler.Exam +import Handler.Exam.AutoOccurrence as Handler.Exam diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs new file mode 100644 index 000000000..908449351 --- /dev/null +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Handler.Exam.AutoOccurrence + ( examAutoOccurrenceCalculateWidget + , postEAutoOccurrenceR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Exam + +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E +import Database.Persist.Sql (updateWhereCount) + + +newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm + { eaofConfig :: ExamAutoOccurrenceConfig + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Default) + +data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm + { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) + , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceAcceptForm + +data ExamAutoOccurrenceButton + = BtnExamAutoOccurrenceCalculate + | BtnExamAutoOccurrenceAccept + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamAutoOccurrenceButton +instance Finite ExamAutoOccurrenceButton + +nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 + +embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id +instance Button UniWorX ExamAutoOccurrenceButton where + btnClasses _ = [BCIsButton, BCPrimary] + + +examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } + = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm + where + eaocForm = + (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) + <*> pure def + +examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm +examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do + (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData + (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty + return (acceptRes *> confirmDataRes, toWidget html <> fvInput confirmDataView <> acceptView) + + +examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget +examAutoOccurrenceCalculateWidget tid ssh csh examn = do + (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def + + wrapForm' BtnExamAutoOccurrenceCalculate formView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding + } + + +postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +postEAutoOccurrenceR tid ssh csh examn = do + (Entity eId Exam{ examOccurrenceRule }, occurrences) <- runDB $ do + exam@(Entity eId _) <- fetchExam tid ssh csh examn + occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ] + return (exam, occurrences) + + + ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def + + calcResult <- formResultMaybe calculateRes $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do + participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do + E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId + return (user, registration) + let participants' = Map.fromList $ do + (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants + return (uid, (userRec, examRegistrationOccurrence)) + occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, examOccurrenceCapacity)) occurrences + (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + return $ Just ExamAutoOccurrenceAcceptForm{..} + + ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult + let confirmWidget = wrapForm confirmView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = confirmEncoding + , formSubmit = FormNoSubmit + } + + formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do + Sum assignedCount <- runDB $ do + let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName)) + eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of + [Entity _ ExamOccurrence{..}] -> Just examOccurrenceName + _other -> Nothing + eaofMapping' <- case eaofMapping'' of + Nothing -> return Nothing + Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight] + Just (Just x ) -> return $ Just x + update eId [ ExamExamOccurrenceMapping =. eaofMapping' ] + fmap fold . iforM eaofAssignment $ \pid occ -> case occ of + Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ] + Nothing -> return mempty + addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount + redirect $ CExamR tid ssh csh examn EUsersR + + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult + + let heading = MsgTitleExamAutoOccurrence tid ssh csh examn + mappingWgt + = let occLoads :: Map ExamOccurrenceId Natural + occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment + + occLoad = fromMaybe 0 . flip Map.lookup occLoads + + occMappingRule = examOccurrenceMappingRule <$> eaofMapping + + loadProp curr max' + | max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + | otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max') + + occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping) + in $(widgetFile "widgets/exam-occurrence-mapping") + + siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "exam/auto-occurrence-confirm") diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 52d90559f..ae40a86c3 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -35,6 +35,7 @@ postEEditR tid ssh csh examn = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index d4e6582a7..7cbfdb32d 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -32,6 +32,7 @@ postCExamNewR tid ssh csh = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = Nothing , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index e072b9e71..1bb67c713 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -145,6 +145,7 @@ getEShowR tid ssh csh examn = do showAchievedPoints = not $ null results showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo) markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) + showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping let heading = prependCourseTitle tid ssh csh $ CI.original examName @@ -161,4 +162,7 @@ getEShowR tid ssh csh examn = do examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") + + occurrenceMapping :: ExamOccurrenceName -> Maybe Widget + occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName) $(widgetFile "exam-show") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 39624ab04..eee9a53b0 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -11,6 +11,8 @@ import Handler.Utils.Exam import Handler.Utils.Users import Handler.Utils.Csv +import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) + import Handler.ExamOffice.Exam (examCloseWidget) import qualified Database.Esqueleto as E @@ -390,7 +392,7 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index f4d1d32d9..9ccb492d4 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,12 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade + , ExamAutoOccurrenceConfig + , eaocMinimizeRooms, eaocFinenessCost + , _eaocMinimizeRooms, _eaocFinenessCost , examAutoOccurrence ) where -import Import.NoFoundation hiding (distribute) +import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E @@ -26,7 +31,7 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Random.Lazy (evalRand) import System.Random (mkStdGen) -import Control.Monad.Random.Class (weightedMay) +import Control.Monad.Random.Class (weighted) import Control.Monad.ST (ST, runST) import Data.Array (Array) @@ -40,9 +45,10 @@ import qualified Data.List as List import Data.ExtendedReal -import qualified Data.Text as Text import qualified Data.Char as Char +import qualified Data.RFC5051 as RFC5051 + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -184,17 +190,32 @@ examGrade Exam{..} mBonus (otoList -> results) where lowerBounds :: [(ExamGrade, Points)] lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' + +data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig + { eaocMinimizeRooms :: Bool + , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default ExamAutoOccurrenceConfig where + def = ExamAutoOccurrenceConfig + { eaocMinimizeRooms = False + , eaocFinenessCost = 0.2 + } + +makeLenses_ ''ExamAutoOccurrenceConfig examAutoOccurrence :: forall seed. Hashable seed => seed -> ExamOccurrenceRule + -> ExamAutoOccurrenceConfig -> Map ExamOccurrenceId Natural -> Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -examAutoOccurrence (hash -> seed) rule occurrences users +examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users | sum occurrences < usersCount + || sum occurrences <= 0 || Map.null users = nullResult | otherwise @@ -203,8 +224,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -> ( Nothing , flip Map.mapWithKey users $ \uid (_, mOcc) -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ - weightedMay $ over _2 fromIntegral <$> occurrences' - in mOcc <|> randomOcc + weighted $ over _2 fromIntegral <$> occurrences' + in Just $ fromMaybe randomOcc mOcc ) _ | Just (postprocess -> (resMapping, result)) <- bestOption -> ( Just $ ExamOccurrenceMapping rule resMapping @@ -221,38 +242,21 @@ examAutoOccurrence (hash -> seed) rule occurrences users users' = case rule of ExamRoomSurname -> Map.fromListWith Set.union - [ (map CI.mk $ unpack userSurname', Set.singleton uid) + [ (map CI.mk $ unpack userSurname, Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let userSurname' = Text.filter Char.isLetter userSurname - , not $ null userSurname' + , not $ null userSurname ] ExamRoomMatriculation -> let matrUsers = Map.fromListWith Set.union [ (map CI.mk $ unpack matriculation', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer + , let Just matriculation' = userMatrikelnummer , not $ null matriculation' ] in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers _ -> Map.singleton [] $ Map.keysSet users - usersGroups :: Natural -- ^ fineness - -> Map [CI Char] (Set UserId) - -- ^ Partition users into monotonously finer - usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union restr users' - where - restr = case rule of - ExamRoomSurname - -> take c - ExamRoomMatriculation - -> reverse . take c . reverse - _other - -> id - - maximumFineness :: Natural - -- ^ Fineness at which `usersGroups` becomes constant - maximumFineness = fromIntegral . F.maximum . Set.map length $ Map.keysSet users' occurrences' :: [(ExamOccurrenceId, Natural)] -- ^ Minimise number of occurrences used @@ -262,6 +266,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -- If a single occurrence can accomodate all participants, pick the one with -- the least capacity occurrences' + | not eaocMinimizeRooms + = Map.toList occurrences | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences = pure $ minimumBy (comparing $ view _2) largeEnoughs | otherwise @@ -278,24 +284,12 @@ examAutoOccurrence (hash -> seed) rule occurrences users , occ : accOccs ) - largestOccurrence :: Num a => a - largestOccurrence = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull occurrences' - - finenessCost :: Natural -> Natural - finenessCost x = round (finenessConst * largestOccurrence) * fromIntegral (length occurrences') * x * x - where - finenessConst :: Rational - -- ^ Cost (scaled to proportion of occurrence) of having higher fineness - finenessConst = 1 % 5 -- TODO: tweak - - distribute :: forall wordId lineId cost. - ( Num cost - , Ord wordId, Ord lineId - ) + _ => [(wordId, Natural)] -> [(lineId, Natural)] - -> Maybe (cost, Map lineId (Set wordId)) + -> (wordId -> wordId -> Extended Rational) + -> Maybe (cost, [(lineId, [wordId])]) -- ^ Distribute the given items (@wordId@s) with associated size in -- contiguous blocks into the given buckets (@lineId@s) such that they are -- filled as evenly as possible (proportionally) @@ -303,8 +297,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -- Return a cost scaled to item-size squared -- -- See under \"Shortest Path\" - distribute wordLengths lineLengths - | null wordLengths = Just (0, Map.empty) + distribute wordLengths lineLengths breakCost + | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ]) | null lineLengths = Nothing | otherwise = let (cost, result) = distribute' in case cost of @@ -344,7 +338,7 @@ examAutoOccurrence (hash -> seed) rule occurrences users bounds = (0, Map.size wordMap) - distribute' :: (Extended Rational, Map lineId (Set wordId)) + distribute' :: (Extended Rational, [(lineId, [wordId])]) distribute' = runST $ do minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) @@ -363,7 +357,22 @@ examAutoOccurrence (hash -> seed) rule occurrences users | otherwise = 0 w = offsets Array.! j - offsets Array.! i - cost <- (+) (widthCost potWidth w) <$> ST.readArray minima i + prevMin <- ST.readArray minima i + let cost = prevMin + widthCost potWidth w + breakCost' + breakCost' + | j < Map.size wordMap + , j > 0 + = breakCost (wordIx # pred j) (wordIx # j) + | otherwise + = 0 + traceM $ show ( i + , j + , potWidth + , w + , (fromRational :: Rational -> Centi) <$> prevMin + , (fromRational :: Rational -> Centi) <$> widthCost potWidth w + , (fromRational :: Rational -> Centi) <$> breakCost' + ) when (isFinite cost) $ do minCost <- ST.readArray minima j when (cost < minCost) $ do @@ -372,66 +381,119 @@ examAutoOccurrence (hash -> seed) rule occurrences users go i' $ succ j | otherwise = return () in go i' $ succ i' + traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima traceM . show =<< ST.getElems breaks let accumResult lineIx j (accCost, accMap) = do i <- ST.readArray breaks j accCost' <- (+) accCost <$> ST.readArray minima j - traceM $ show (accCost', lineIx, [i .. pred j]) - let accMap' = Map.insertWith Set.union (lineIxs List.!! lineIx) (Set.fromList $ map (review wordIx) [i .. pred j]) accMap + traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j)) + let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap if | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') | otherwise -> return (accCost', accMap') lineIxs = reverse $ map (view _1) lineLengths - in accumResult 0 (Map.size wordMap) (0, Map.empty) + in accumResult 0 (Map.size wordMap) (0, []) widthCost :: Natural -> Natural -> Extended Rational widthCost lineWidth w | lineWidth < w = PosInf - | otherwise = Finite (((fromIntegral lineWidth % fromIntegral w) - optimumRatio) * fromIntegral longestLine) ^ 2 + | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio) * fromIntegral longestLine) ^ 2 where - optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) lineLengths) (map (view _2) wordLengths) + optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + charCost :: [CI Char] -> [CI Char] -> Extended Rational + charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 + where + longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences' - options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))] - options = do - fineness <- [0..maximumFineness] - - let usersGroups' = fromIntegral . Set.size <$> usersGroups fineness - - traceM $ show usersGroups' - traceM . show $ map snd occurrences' - -- The algorithm used in `distribute` produces no usable result if the - -- situation occurs, that a single item does not fit within a bucket. - -- In a naive attempt to prevent this we ensure that all items fit into - -- all buckets. - guard . (\(fromIntegral -> maxSize) -> all ((>= maxSize) . view _2) occurrences') . maybe 0 maximum $ fromNullable usersGroups' + lcp :: Eq a => [a] -> [a] -> [a] + -- ^ Longest common prefix + lcp [] _ = [] + lcp _ [] = [] + lcp (a:as) (b:bs) + | a == b = a:lcp as bs + | otherwise = [] - let - packets :: [([CI Char], Natural)] - packets = Map.toAscList usersGroups' - (resultCost, result) <- hoistMaybe $ distribute packets occurrences' + bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] + bestOption = do + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost - traceM $ show (fineness, finenessCost fineness, resultCost) - traceM . show . map (foldMap $ \prefix -> Sum $ usersGroups' Map.! prefix) $ Map.elems result - - return (fineness, (resultCost, result)) - bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char])) - bestOption = options - & over _tail (takeWhile $ \(fineness, (resCost, _)) -> finenessCost fineness <= resCost) - & map (view $ _2 . _2) - & fmap last . fromNullable + -- traceM $ show cost - postprocess :: Map ExamOccurrenceId (Set [CI Char]) - -> ( [(ExamOccurrenceId, [CI Char])] + return res + + postprocess :: [(ExamOccurrenceId, [[CI Char]])] + -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) , Map UserId (Maybe ExamOccurrenceId) ) postprocess result = (resultAscList, resultUsers) where - resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result + resultAscList = Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + where + accRes _ [] = [] + accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) + | Just minA <- prevEnd <|> preview _head nsA + , Just maxA <- nsA ^? _last + , Just minB <- nsB ^? _head + = let common = maxA `lcp` minB + mayRange' = mayRange . max 1 . succ $ length common + suffA = CI.foldedCase <$> drop (length common) maxA + suffB = CI.foldedCase <$> drop (length common) minB + in if + | mayRange (succ $ length common) maxA + , mayRange (succ $ length common) minA + , mayRange (succ $ length common) minB + , firstA : _ <- suffA + , firstB : _ <- suffB + -> let break' = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) + & floor + & Char.chr + & Char.toUpper + & CI.mk + & pure + & (common ++) + succBreak = fmap reverse . go $ reverse break' + where + go [] = Nothing + go (c:cs) + | c' <- CI.map succ c + , c' `Set.member` rangeAlphabet + = Just $ c' : cs + | otherwise + = go cs + in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) . Set.filter (not . mayRange') $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) + | otherwise + -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) + | null nsA + = accRes prevEnd $ (occB, nsB) : xs + | otherwise -- null nsB + = accRes prevEnd $ (occA, nsA) : xs + accRes prevEnd [(occZ, nsZ)] + | Just minAlpha <- Set.lookupMin rangeAlphabet + , Just maxAlpha <- Set.lookupMax rangeAlphabet + , minZ <- fromMaybe (pure minAlpha) prevEnd + = let commonLength = max 1 $ length minZ + in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ) + | otherwise + = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) resultUsers = Map.fromList $ do - (occId, buckets) <- Map.toList result - user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b `List.isPrefixOf` b') $ Map.toList users') buckets + (occId, buckets) <- result + user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b == b') $ Map.toList users') buckets return (user, Just occId) + + occSize :: Num a => ExamOccurrenceId -> a + occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers + + rangeAlphabet :: Set (CI Char) + rangeAlphabet + | ExamRoomSurname <- rule + = Set.fromList $ map CI.mk ['A'..'Z'] + | ExamRoomMatriculation <- rule + = Set.fromList $ map CI.mk ['0'..'9'] + | otherwise + = mempty + mayRange :: Int -> [CI Char] -> Bool + mayRange l = all (`Set.member` rangeAlphabet) . take l diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 994fe893d..be3e0424d 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -8,6 +8,8 @@ import Text.Hamlet (shamletFile) import Handler.Utils.DateTime +import qualified Data.Char as Char + --------- -- Simple utilities for consistent display @@ -102,3 +104,14 @@ i18n :: forall m msg. , RenderMessage (HandlerSite m) msg ) => msg -> m () i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m)) + + +examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget +examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description") + where + titleCase = over _head Char.toUpper . map CI.foldedCase + doPrefix + | ExamRoomMatriculation <- rule + = False + | otherwise + = True diff --git a/src/Model.hs b/src/Model.hs index f59815c79..3821126b6 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -37,6 +37,12 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +deriving newtype instance ToJSONKey UserId +deriving newtype instance FromJSONKey UserId +deriving newtype instance ToJSONKey ExamOccurrenceId +deriving newtype instance FromJSONKey ExamOccurrenceId + -- ToMarkup and ToMessage instances for displaying selected database primary keys instance ToMarkup (Key School) where diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index e6186c2b0..59c4396dd 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -11,7 +11,14 @@ module Model.Types.Exam , _examResult , ExamBonusRule(..) , ExamOccurrenceRule(..) + , examOccurrenceRuleAutomatic + , ExamOccurrenceMappingDescription(..) + , _eaomrStart, _eaomrEnd, _eaomrSpecial + , _ExamOccurrenceMappingRange, _ExamOccurrenceMappingSpecial , ExamOccurrenceMapping(..) + , _examOccurrenceMappingRule + , _examOccurrenceMappingMapping + , traverseExamOccurrenceMapping , ExamGrade(..) , numberGrade , ExamGradeDefCenter(..) @@ -28,6 +35,8 @@ import Import.NoModel import Model.Types.Common import qualified Data.Text as Text +import qualified Data.Map as Map +import qualified Data.Set as Set import Utils.Lens.TH @@ -44,6 +53,8 @@ import Text.Blaze (ToMarkup(..)) import qualified Data.Foldable +import Data.Aeson (genericToJSON, genericParseJSON) + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -152,18 +163,51 @@ deriveJSON defaultOptions , tagSingleConstructors = True } ''ExamOccurrenceRule derivePersistFieldJSON ''ExamOccurrenceRule +makePrisms ''ExamOccurrenceRule + +examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool +examOccurrenceRuleAutomatic x = or $ map ($ x) + [ is _ExamRoomSurname + , is _ExamRoomMatriculation + , is _ExamRoomRandom + ] + +data ExamOccurrenceMappingDescription + = ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] } + | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 3 + } ''ExamOccurrenceMappingDescription + +makeLenses_ ''ExamOccurrenceMappingDescription +makePrisms ''ExamOccurrenceMappingDescription data ExamOccurrenceMapping roomId = ExamOccurrenceMapping { examOccurrenceMappingRule :: ExamOccurrenceRule - , examOccurrenceMappingMapping :: [(roomId, [CI Char])] + , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) } deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 3 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = False - } ''ExamOccurrenceMapping +instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } +instance (FromJSONKey roomId, Ord roomId) => FromJSON (ExamOccurrenceMapping roomId) where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } derivePersistFieldJSON ''ExamOccurrenceMapping +makeLenses_ ''ExamOccurrenceMapping + +traverseExamOccurrenceMapping :: Ord roomId' + => Traversal (ExamOccurrenceMapping roomId) (ExamOccurrenceMapping roomId') roomId roomId' +traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1 + data ExamGrade = Grade50 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 52024081d..4b12d47b4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,6 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDAllUsersAction | FIDLanguage + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/stack.yaml.lock b/stack.yaml.lock index e67cca322..8e2842628 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -277,6 +277,13 @@ packages: sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 original: hackage: wai-middleware-prometheus-1.0.0 +- completed: + hackage: extended-reals-0.2.3.0@sha256:78a498d703fffcecfba8e66cfb3e64c4307b2c126a442f6d28cfdd997829f1bf,1563 + pantry-tree: + size: 398 + sha256: 29629bb0ac41c49671b7f792e540165ee091eb24ffd0eaff229a2f40cc03f3af + original: + hackage: extended-reals-0.2.3.0 snapshots: - completed: size: 498180 diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 3652474ef..0b6bde895 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -114,6 +114,22 @@ $if not (null occurrences) _{MsgExamRoomAssigned} $if not occurrenceAssignmentsVisible \ ^{isVisible False} + $if showOccurrenceMappingColumn + $case fmap examOccurrenceMappingRule examExamOccurrenceMapping + $of Just ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of Just ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of _ + + $if not occurrenceAssignmentsVisible + ^{isVisible False} _{MsgExamRoomDescription} $forall (occurrence, registered) <- occurrences @@ -133,6 +149,10 @@ $if not (null occurrences) $nothing $if registered #{iconOK} + $if showOccurrenceMappingColumn + + $maybe mappingWgt <- occurrenceMapping examOccurrenceName + ^{mappingWgt} $maybe desc <- examOccurrenceDescription #{desc} diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index 06e3e489f..68cc39d21 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -1,6 +1,9 @@ $newline never
^{closeWgt} +$if examOccurrenceRuleAutomatic examOccurrenceRule +
+ ^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
$if computedValues ^{computedValuesTip} diff --git a/templates/exam/auto-occurrence-confirm.hamlet b/templates/exam/auto-occurrence-confirm.hamlet new file mode 100644 index 000000000..0e94455e7 --- /dev/null +++ b/templates/exam/auto-occurrence-confirm.hamlet @@ -0,0 +1,3 @@ +$newline never +^{mappingWgt} +^{confirmWidget} diff --git a/templates/widgets/exam-occurrence-mapping-description.hamlet b/templates/widgets/exam-occurrence-mapping-description.hamlet new file mode 100644 index 000000000..356911383 --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping-description.hamlet @@ -0,0 +1,15 @@ +$newline never +
    + $forall desc <- descriptions +
  • + $case desc + $of ExamOccurrenceMappingRange minChars maxChars + $if doPrefix + #{titleCase minChars}… – #{titleCase maxChars}… + $else + …#{titleCase minChars} – …#{titleCase maxChars} + $of ExamOccurrenceMappingSpecial special + $if doPrefix + #{titleCase special}… + $else + …#{titleCase special} diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet new file mode 100644 index 000000000..36f99950e --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -0,0 +1,41 @@ +$newline never + + + + + $forall Entity occId ExamOccurrence{ examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription, examOccurrenceCapacity } <- occurrences + +
    + _{MsgExamRoomName} + + _{MsgExamRoomLoad} + $maybe rule <- occMappingRule + $case rule + $of ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $of ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $of _ + + + _{MsgExamRoom} + + _{MsgExamRoomTime} + + _{MsgExamRoomDescription} +
    + _{examOccurrenceName} + + _{loadProp (occLoad occId) examOccurrenceCapacity} + $maybe mappingWgt <- occMapping occId + + ^{mappingWgt} + + #{examOccurrenceRoom} + + ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} + + $maybe desc <- examOccurrenceDescription + #{desc} diff --git a/test/Database.hs b/test/Database.hs index 8335ef6ac..9038f14cb 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -505,6 +505,7 @@ fillDb = do , examGradingRule = Nothing , examBonusRule = Nothing , examOccurrenceRule = ExamRoomManual + , examExamOccurrenceMapping = Nothing , examVisibleFrom = Just now , examRegisterFrom = Just now , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now From 214e8951e49bada7081b35cdf4a570eba3890f87 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 20:50:27 +0100 Subject: [PATCH 06/31] feat: additional exam functions on show page --- messages/uniworx/de-de-formal.msg | 4 +++- src/Handler/Exam/Show.hs | 10 +++++++++- templates/exam-show.hamlet | 13 +++++++++++++ templates/exam-users.hamlet | 3 +++ 4 files changed, 28 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index f31a52272..459a50be3 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2046,6 +2046,7 @@ MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E ExamOfficeOptOutsChanged: Zuständige Prüfungsbeauftragte erfolgreich angepasst +ExamCloseHeading: Klausur abschließen BtnCloseExam: Klausur abschließen ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsbeauftragte, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert. ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht. @@ -2273,11 +2274,12 @@ ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ f ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt. ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. +ExamAutoOccurrenceHeading: Automatische Raumverteilung ExamAutoOccurrenceMinimizeRooms: Verwendete Räume minimieren ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen -TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid}-#{ssh}-#{csh} #{examn}: Automatische Raumverteilung +TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raumverteilung BtnExamAutoOccurrenceCalculate: Verteilung berechnen BtnExamAutoOccurrenceAccept: Verteilung akzeptieren ExamRoomMappingSurname: Nachnamen beginnend mit diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 1bb67c713..febf7c4f3 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -5,6 +5,10 @@ module Handler.Exam.Show import Import import Handler.Exam.Register +import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) + +import Handler.ExamOffice.Exam (examCloseWidget) + import Data.Map ((!?)) import qualified Data.Map as Map @@ -22,7 +26,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do + (Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -76,6 +80,8 @@ getEShowR tid ssh csh examn = do let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown examClosedShown = lecturerInfoShown + showCloseWidget = lecturerInfoShown + showAutoOccurrenceCalculateWidget = lecturerInfoShown sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] @@ -147,6 +153,8 @@ getEShowR tid ssh csh examn = do markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping + closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId + let heading = prependCourseTitle tid ssh csh $ CI.original examName siteLayoutMsg heading $ do diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 0b6bde895..ac8653319 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -88,6 +88,19 @@ $maybe desc <- examDescription
    _{MsgExamRegistration}
    ^{registerWdgt} +$if showCloseWidget && is _Nothing examClosed +
    +

    + _{MsgExamCloseHeading} + \ ^{isVisible False} + ^{closeWgt} +$if examOccurrenceRuleAutomatic examOccurrenceRule && showAutoOccurrenceCalculateWidget +
    +

    + _{MsgExamAutoOccurrenceHeading} + \ ^{isVisible False} + ^{examAutoOccurrenceCalculateWidget tid ssh csh examn} + $if not (null occurrences)
    diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index 68cc39d21..9e85b0605 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -1,8 +1,11 @@ $newline never
    + $if is _Nothing examClosed +

    _{MsgExamCloseHeading} ^{closeWgt} $if examOccurrenceRuleAutomatic examOccurrenceRule
    +

    _{MsgExamAutoOccurrenceHeading} ^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
    $if computedValues From ea2e236012cd89932cf4adf352c1fd48c00e44ac Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:00:35 +0100 Subject: [PATCH 07/31] chore: test for missing translations --- messages/uniworx/de-de-formal.msg | 12 ++++++------ messages/uniworx/en-eu.msg | 14 ++++++++++++++ missing-translations.sh | 6 +++++- package.json | 3 ++- 4 files changed, 27 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 459a50be3..b3448e45d 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1267,7 +1267,7 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste -BreadcrumbExamAutoOccurrence: Automatische Raumverteilung +BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -2274,13 +2274,13 @@ ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ f ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt. ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. -ExamAutoOccurrenceHeading: Automatische Raumverteilung -ExamAutoOccurrenceMinimizeRooms: Verwendete Räume minimieren -ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? +ExamAutoOccurrenceHeading: Automatische Raum-/Terminverteilung +ExamAutoOccurrenceMinimizeRooms: Verwendete Räume/Termine minimieren +ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen/Terminen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen -TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raumverteilung -BtnExamAutoOccurrenceCalculate: Verteilung berechnen +TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raum-/Terminverteilung +BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen BtnExamAutoOccurrenceAccept: Verteilung akzeptieren ExamRoomMappingSurname: Nachnamen beginnend mit ExamRoomMappingMatriculation: Matrikelnummern endend in diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 1f697b94d..3069eb305 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1266,6 +1266,7 @@ BreadcrumbExternalExamGrades: Exam results BreadcrumbExternalExamStaffInvite: Invitation BreadcrumbParticipantsList: Lists of course participants BreadcrumbParticipants: Course participants +BreadcrumbExamAutoOccurrence: Automatic occurrence/room distribution ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} @@ -2044,6 +2045,7 @@ MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to publish thi ExamOfficeOptOutsChanged: Successfully adjusted relevant exam offices +ExamCloseHeading: Close exam BtnCloseExam: Close exam ExamCloseTip: When an exam is closed all relevant exam offices, which pull exam achievements from Uni2work, are informed and kept up to date with changes. ExamCloseReminder: Please close the exam as soon as possible, when exam achievements are no longer expected to change e.g. after inspection of the exam has concluced. @@ -2270,3 +2272,15 @@ ExternalExamCourseExists: This course already exists with uni2work. Exams for co ExternalExamExists coursen@CourseName examn@ExamName: Exam “#{examn}” already exists for course “#{coursen}”. ExternalExamCreated coursen@CourseName examn@ExamName: Succesfully created exam “#{examn}” for course “#{coursen}”. ExternalExamEdited coursen@CourseName examn@ExamName: Succesfully edited exam “#{examn}” for course “#{coursen}”. + +ExamAutoOccurrenceHeading: Automatic occurrence/room distribution +ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used +ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest). +ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed +ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEn num "participant" "participants"} +TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution +BtnExamAutoOccurrenceCalculate: Calculate assignment rules +BtnExamAutoOccurrenceAccept: Accept assignments +ExamRoomMappingSurname: Surnames starting with +ExamRoomMappingMatriculation: Matriculation numbers ending in +ExamRoomLoad: Utilisation \ No newline at end of file diff --git a/missing-translations.sh b/missing-translations.sh index 6cfa7daef..4077c7b21 100755 --- a/missing-translations.sh +++ b/missing-translations.sh @@ -20,6 +20,8 @@ for msgFile (${msgFiles}); do fi done +difference=false + for msgDirectory (${msgDirectories}); do typeset -a dirMsgFiles dirMsgFiles=() @@ -48,5 +50,7 @@ for msgDirectory (${msgDirectories}); do printf ">>> %s\n" ${msgDirectory} diff --suppress-common-lines -wB ${diffArgs} - ) + ) || difference=true done + +$difference && exit 1 diff --git a/package.json b/package.json index 95f3968fe..78a152fce 100644 --- a/package.json +++ b/package.json @@ -7,7 +7,7 @@ "license": "ISC", "scripts": { "start": "npm-run-all frontend:build --parallel \"frontend:build:watch\" \"yesod:start\"", - "test": "run-s frontend:test yesod:test", + "test": "run-s frontend:test yesod:test i18n:test", "lint": "run-s frontend:lint yesod:lint", "build": "run-s frontend:build yesod:build", "cbt": "./cbt.sh", @@ -23,6 +23,7 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack --progress", "frontend:build:watch": "webpack --watch --progress", + "i18n:test": "./missing-translations.sh", "prerelease": "./is-clean.sh && npm run test", "release": "standard-version -a", "postrelease": "git push --follow-tags origin master" From 62e8c89161dc604aa5b03feb15b92514f3573948 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:01:24 +0100 Subject: [PATCH 08/31] test: fix fakeUser --- test/User.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/User.hs b/test/User.hs index 1efb8d673..919ca7019 100644 --- a/test/User.hs +++ b/test/User.hs @@ -29,12 +29,16 @@ fakeUser adjUser = adjUser User{..} userTitle = Nothing userTheme = userDefaultTheme userMaxFavourites = userDefaultMaxFavourites + userMaxFavouriteTerms = userDefaultMaxFavouriteTerms userDateTimeFormat = userDefaultDateTimeFormat userDateFormat = userDefaultDateFormat userTimeFormat = userDefaultTimeFormat userDownloadFiles = userDefaultDownloadFiles + userLanguages = Nothing userWarningDays = userDefaultWarningDays - userMailLanguages = def + userCsvOptions = def + userSex = Nothing + userShowSex = userDefaultShowSex userNotificationSettings = def userCreated = unsafePerformIO getCurrentTime userLastLdapSynchronisation = Nothing From ad5494ef03604250fbec63d4e48f0d6bbd66f87f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:02:39 +0100 Subject: [PATCH 09/31] fix: typo --- messages/uniworx/en-eu.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 3069eb305..4641ebd9f 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2277,7 +2277,7 @@ ExamAutoOccurrenceHeading: Automatic occurrence/room distribution ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest). ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed -ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEn num "participant" "participants"} +ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEN num "participant" "participants"} TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution BtnExamAutoOccurrenceCalculate: Calculate assignment rules BtnExamAutoOccurrenceAccept: Accept assignments From 1626d6bb694505f291afc6cc3f66e3e53f75f30a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:04:56 +0100 Subject: [PATCH 10/31] test: fix imports --- test/TestImport.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/TestImport.hs b/test/TestImport.hs index 9106ec67e..3c9b42427 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -53,7 +53,6 @@ import Control.Monad.Catch as X hiding (Handler(..)) import Control.Monad.Trans.Resource (runResourceT) -import Settings import Settings.WellKnownFiles as X import Data.CaseInsensitive as X (CI) From 3aea3561b0e1d262c18dcf7ee2a2575914137589 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:08:56 +0100 Subject: [PATCH 11/31] chore: fix translations test --- missing-translations.sh | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/missing-translations.sh b/missing-translations.sh index 4077c7b21..080a38620 100755 --- a/missing-translations.sh +++ b/missing-translations.sh @@ -20,7 +20,7 @@ for msgFile (${msgFiles}); do fi done -difference=false +difference=0 for msgDirectory (${msgDirectories}); do typeset -a dirMsgFiles @@ -50,7 +50,9 @@ for msgDirectory (${msgDirectories}); do printf ">>> %s\n" ${msgDirectory} diff --suppress-common-lines -wB ${diffArgs} - ) || difference=true + ) || difference=1 done -$difference && exit 1 +if [[ $difference -ne 0 ]]; then + exit 1 +fi From 3bd75200874c812afc425d9652318b57336c31fb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:20:59 +0100 Subject: [PATCH 12/31] feat: bump changelog --- templates/i18n/changelog/de-de-formal.hamlet | 8 ++++++++ templates/i18n/changelog/en-eu.hamlet | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index 3da252aaa..e7a030b42 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,13 @@ $newline never
    +
    + ^{formatGregorianW 2020 01 29} +
    +
      +
    • + Automatische Verteilung von Klausurteilnehmern auf + Termine/Räume +
      ^{formatGregorianW 2020 01 17}
      diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index bb0c941cb..795925a95 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -1,5 +1,13 @@ $newline never
      +
      + ^{formatGregorianW 2020 01 29} +
      +
        +
      • + Automated distribution of exam participants over configured + occurrences/rooms +
        ^{formatGregorianW 2020 01 17}
        From 7140618a5c590b0038a1f3f48c9831ed247a758c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 21:46:16 +0100 Subject: [PATCH 13/31] chore: remove traces --- src/Handler/Utils/Exam.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 9ccb492d4..a7188cb0f 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} - module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam @@ -365,14 +363,14 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences = breakCost (wordIx # pred j) (wordIx # j) | otherwise = 0 - traceM $ show ( i - , j - , potWidth - , w - , (fromRational :: Rational -> Centi) <$> prevMin - , (fromRational :: Rational -> Centi) <$> widthCost potWidth w - , (fromRational :: Rational -> Centi) <$> breakCost' - ) + -- traceM $ show ( i + -- , j + -- , potWidth + -- , w + -- , (fromRational :: Rational -> Centi) <$> prevMin + -- , (fromRational :: Rational -> Centi) <$> widthCost potWidth w + -- , (fromRational :: Rational -> Centi) <$> breakCost' + -- ) when (isFinite cost) $ do minCost <- ST.readArray minima j when (cost < minCost) $ do @@ -381,13 +379,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences go i' $ succ j | otherwise = return () in go i' $ succ i' - traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima - traceM . show =<< ST.getElems breaks + -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima + -- traceM . show =<< ST.getElems breaks let accumResult lineIx j (accCost, accMap) = do i <- ST.readArray breaks j accCost' <- (+) accCost <$> ST.readArray minima j - traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j)) + -- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j)) let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap if | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') From 2e2949c7ab9a2eea920a89e88ce213d90c1c5821 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 22:18:04 +0100 Subject: [PATCH 14/31] chore(gitlab-ci): interruptable & resource_groups --- .gitlab-ci.yml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9780156a1..68c431a15 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -49,6 +49,7 @@ npm install: name: "${CI_JOB_NAME}" expire_in: "1 day" retry: 2 + interruptable: true frontend:build: stage: frontend:build @@ -67,6 +68,7 @@ frontend:build: dependencies: - npm install retry: 2 + interruptable: true frontend:lint: stage: lint @@ -78,6 +80,7 @@ frontend:lint: dependencies: - npm install retry: 2 + interruptable: true yesod:build:dev: stage: yesod:build @@ -105,6 +108,7 @@ yesod:build:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptable: true yesod:build: stage: yesod:build @@ -131,6 +135,8 @@ yesod:build: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptable: true + resource_group: ram frontend:test: stage: test @@ -149,6 +155,7 @@ frontend:test: dependencies: - npm install retry: 2 + interruptable: true hlint:dev: stage: lint @@ -168,6 +175,7 @@ hlint:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptable: true yesod:test:dev: services: @@ -191,6 +199,7 @@ yesod:test:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptable: true hlint: stage: lint @@ -210,6 +219,8 @@ hlint: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptable: true + resource_group: ram yesod:test: services: @@ -233,6 +244,8 @@ yesod:test: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptable: true + resource_group: ram deploy:uniworx3: stage: deploy @@ -254,3 +267,4 @@ deploy:uniworx3: only: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ + resource_group: uniworx3 From 29b1a436d440f3e9fc20510df6a10527f4ecdf84 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 22:20:08 +0100 Subject: [PATCH 15/31] chore(gitlab-ci): fix typo --- .gitlab-ci.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 68c431a15..97f40010b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -49,7 +49,7 @@ npm install: name: "${CI_JOB_NAME}" expire_in: "1 day" retry: 2 - interruptable: true + interruptible: true frontend:build: stage: frontend:build @@ -68,7 +68,7 @@ frontend:build: dependencies: - npm install retry: 2 - interruptable: true + interruptible: true frontend:lint: stage: lint @@ -80,7 +80,7 @@ frontend:lint: dependencies: - npm install retry: 2 - interruptable: true + interruptible: true yesod:build:dev: stage: yesod:build @@ -108,7 +108,7 @@ yesod:build:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true yesod:build: stage: yesod:build @@ -135,7 +135,7 @@ yesod:build: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true resource_group: ram frontend:test: @@ -155,7 +155,7 @@ frontend:test: dependencies: - npm install retry: 2 - interruptable: true + interruptible: true hlint:dev: stage: lint @@ -175,7 +175,7 @@ hlint:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true yesod:test:dev: services: @@ -199,7 +199,7 @@ yesod:test:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true hlint: stage: lint @@ -219,7 +219,7 @@ hlint: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true resource_group: ram yesod:test: @@ -244,7 +244,7 @@ yesod:test: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 - interruptable: true + interruptible: true resource_group: ram deploy:uniworx3: From 45506bd7736256058d20fc098727d36286f1d410 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 22:20:46 +0100 Subject: [PATCH 16/31] chore(gitlab-ci): disable resource_group due to gitlab version --- .gitlab-ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 97f40010b..b7ec49c62 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -136,7 +136,7 @@ yesod:build: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - resource_group: ram + # resource_group: ram frontend:test: stage: test @@ -220,7 +220,7 @@ hlint: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - resource_group: ram + # resource_group: ram yesod:test: services: @@ -245,7 +245,7 @@ yesod:test: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - resource_group: ram + # resource_group: ram deploy:uniworx3: stage: deploy @@ -267,4 +267,4 @@ deploy:uniworx3: only: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ - resource_group: uniworx3 + # resource_group: uniworx3 From 2b56f26c45bb0c17bd2b4ad0a491b912c96e9acb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 22:53:35 +0100 Subject: [PATCH 17/31] feat(exams): improve occurrence display --- messages/uniworx/de-de-formal.msg | 5 +++-- messages/uniworx/en-eu.msg | 3 ++- src/Handler/Exam/Show.hs | 4 ++++ templates/exam-show.hamlet | 15 +++++++++++---- 4 files changed, 20 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b3448e45d..7504c4f34 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1516,6 +1516,7 @@ ExamParticipantsRegisterHeading: Prüfungsteilnehmer hinzufügen ExamParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt ExamName: Name +ExamRoom: Raum ExamTime: Termin ExamsHeading: Prüfungen ExamNameTip: Muss innerhalb der Veranstaltung eindeutig sein @@ -1587,11 +1588,11 @@ ExamRoomFifo': Auswahl durch Teilnehmer bei Anmeldung ExamOccurrence: Termin/Raum ExamNoOccurrence: Kein Termin/Raum ExamNoSuchOccurrence: Termin/Raum existiert nicht (mehr) -ExamOccurrences: Prüfungen +ExamOccurrences: Termine ExamRooms: Räume +ExamTimes: Termine ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoomName: Interne Bezeichnung -ExamRoom: Raum ExamRoomCapacity: Kapazität ExamRoomCapacityNegative: Kapazität darf nicht negativ sein ExamRoomTime: Termin diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 4641ebd9f..db8199833 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1514,6 +1514,7 @@ ExamParticipantsRegisterHeading: Add exam participants ExamParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email ExamName: Name +ExamRoom: Room ExamTime: Time ExamsHeading: Exams ExamNameTip: Needs to be unique within the course @@ -1587,9 +1588,9 @@ ExamNoOccurrence: No occurrence/room ExamNoSuchOccurrence: Occurrence/Room does not exist (anymore) ExamOccurrences: Exams ExamRooms: Rooms +ExamTimes: Times ExamRoomAlreadyExists: Occurrence already configured ExamRoomName: Internal name -ExamRoom: Room ExamRoomCapacity: Capacity ExamRoomCapacityNegative: Capacity may not be negative ExamRoomTime: Time diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index febf7c4f3..50c2c1fb2 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -103,6 +103,10 @@ getEShowR tid ssh csh examn = do fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + examRoom = do + Entity _ primeOcc <- occurrences ^? _head . _1 + guard $ all (\(Entity _ occ, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences + return $ examOccurrenceRoom primeOcc registerWidget mOcc | isRegistered <- is _Just $ join registered , examOccurrenceRule /= ExamRoomFifo || (isRegistered && not (any snd occurrences)) diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index ac8653319..48754437c 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -47,6 +47,9 @@ $maybe desc <- examDescription $maybe publishAssignments <- examPublishOccurrenceAssignments
        _{MsgExamPublishOccurrenceAssignmentsParticipant}
        ^{formatTimeW SelFormatDateTime publishAssignments} + $maybe room <- examRoom +
        _{MsgExamRoom} +
        #{room} $if examTimes
        _{MsgExamTime}
        @@ -106,9 +109,11 @@ $if not (null occurrences)

        $if examTimes - _{MsgExamOccurrences} - $else _{MsgExamRooms} + $elseif is _Just examRoom + _{MsgExamTimes} + $else + _{MsgExamOccurrences} @@ -116,7 +121,8 @@ $if not (null occurrences) $if occurrenceNamesShown
        _{MsgExamRoomName} \ ^{isVisible False} - _{MsgExamRoom} + $if is _Nothing examRoom + _{MsgExamRoom} $if not examTimes _{MsgExamRoomTime} $if showOccurrenceRegisterColumn @@ -151,7 +157,8 @@ $if not (null occurrences)
        #{examOccurrenceName} - #{examOccurrenceRoom} + $if is _Nothing examRoom + #{examOccurrenceRoom} $if not examTimes ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} From 7fc9fefb0a255dcf627320e89802fa5b6869c542 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 23:11:19 +0100 Subject: [PATCH 18/31] feat(exams): add warning about multiple automatic distributions --- src/Handler/Exam/AutoOccurrence.hs | 2 +- .../de-de-formal.hamlet | 19 +++++++++++++++++++ .../en-eu.hamlet | 19 +++++++++++++++++++ 3 files changed, 39 insertions(+), 1 deletion(-) create mode 100644 templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet create mode 100644 templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 908449351..925df22fd 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -62,7 +62,7 @@ examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> Ex examAutoOccurrenceCalculateWidget tid ssh csh examn = do (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def - wrapForm' BtnExamAutoOccurrenceCalculate formView def + wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR , formEncoding } diff --git a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet new file mode 100644 index 000000000..ef8c4e35b --- /dev/null +++ b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet @@ -0,0 +1,19 @@ +$newline never +

        + Bei der Berechnung der Verteilung werden stets alle # + Klausurteilnehmer berücksichtigt, unabhängig davon, ob ihnen bereits # + ein Raum/Termin zugewiesen ist, oder nicht. + +
        + + Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten # + Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin # + haben. + +
        + + Dies kann bei mehrfacher Berechnung neuer Verteilungen dazu führen, # + dass die Zuteilung der meisten Klausurteilnehmer nicht mit der # + aktuellen Verteilung übereinstimmt. + +^{formView} diff --git a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet new file mode 100644 index 000000000..a6b938066 --- /dev/null +++ b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet @@ -0,0 +1,19 @@ +$newline never +

        + When assignment rules are calculated all exam participants are # + considered, regardless of whether they are already assigned to an # + occurrence/room. + +
        + + Nonetheless only exam participants, who are not already assigned to # + an occurrence/room, will be assigned according to the newly # + calculated assignment rules. + +
        + + Thus calculating new assignment rules multiple times may lead to a # + situation in which the occurrence/room assignments of most # + participants do not match the newest assignment rules. + +^{formView} From 6a7442728fc82426c307444c244103fc74be1b53 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 23:38:16 +0100 Subject: [PATCH 19/31] chore(release): 10.5.0 --- CHANGELOG.md | 27 +++++++++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 30 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e7395aaf2..e842425f3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,33 @@ 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. +## [10.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.1...v10.5.0) (2020-01-29) + + +### Bug Fixes + +* submission user notification recipients for pseudonym subs ([a7b7bdb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7b7bdb)) +* typo ([ad5494e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ad5494e)) + + +### Features + +* **exams:** add warning about multiple automatic distributions ([7fc9fef](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7fc9fef)) +* **exams:** improve occurrence display ([2b56f26](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2b56f26)) +* additional exam functions on show page ([214e895](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/214e895)) +* bump changelog ([3bd7520](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3bd7520)) +* **exam:** start work on automatic exam-occurrence assignment ([282df86](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/282df86)) +* **exam:** working prototype of automatic occurrence assignment ([f89545f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f89545f)) +* **exams:** automatic exam occurrence assignment ([e994faf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e994faf)) + + +### Tests + +* fix fakeUser ([62e8c89](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/62e8c89)) +* fix imports ([1626d6b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1626d6b)) + + + ### [10.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.0...v10.4.1) (2020-01-17) diff --git a/package-lock.json b/package-lock.json index b7daf0eed..532f16452 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "10.4.1", + "version": "10.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 78a152fce..5a2e33339 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "10.4.1", + "version": "10.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 86e2ff3c8..f664132c4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 10.4.1 +version: 10.5.0 dependencies: - base From 5bff34ed0a1b2d4d160c506cbe7090209d28da66 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 08:31:52 +0100 Subject: [PATCH 20/31] fix: non-exhaustive patterns --- src/Handler/Exam/Show.hs | 2 +- src/Handler/Utils/Exam.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 50c2c1fb2..e1bec059e 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -83,7 +83,7 @@ getEShowR tid ssh csh examn = do showCloseWidget = lecturerInfoShown showAutoOccurrenceCalculateWidget = lecturerInfoShown - sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] + sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, mPoints <- examPartMaxPoints ^.. _Just ] noBonus = fromMaybe False $ do guardM $ bonusOnlyPassed <$> examBonusRule diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index a7188cb0f..612ce4aad 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -249,8 +249,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences = Map.fromListWith Set.union [ (map CI.mk $ unpack matriculation', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let Just matriculation' = userMatrikelnummer - , not $ null matriculation' + , matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null) ] in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers _ -> Map.singleton [] $ Map.keysSet users From 3ef10d98a174ce6c9fb5e7aaf2f2642073ea65c9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 12:30:26 +0100 Subject: [PATCH 21/31] fix: exam auto-occurrence by matriculation --- src/Handler/Utils/Exam.hs | 75 +++++++++++++++---- .../widgets/exam-occurrence-mapping.hamlet | 4 +- 2 files changed, 64 insertions(+), 15 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 612ce4aad..844919ed2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -415,12 +415,43 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | otherwise = [] bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] - bestOption = do - (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost + bestOption = case rule of + ExamRoomSurname -> do + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost + -- traceM $ show cost + return res + ExamRoomMatriculation -> do + let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users' + -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' - -- traceM $ show cost + distributeFine :: Natural -> Maybe (Extended Rational, _) + distributeFine n = distribute (usersFineness n) occurrences' charCost - return res + maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' + + resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural + resultFineness (map (view _2) -> res) + | Just res' <- fromNullable res + = maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res') + | otherwise = 0 + where + transFineness :: [[CI Char]] -> [[CI Char]] -> Natural + transFineness nsA nsB + | Just maxA <- nsA ^? _last + , Just minB <- nsB ^? _head + = succ . List.genericLength $ maxA `lcp` minB + | otherwise + = 0 + + genResults f + | f > maximumFineness = [] + | otherwise = + let mRes = distributeFine f + in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness) + + (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1 + return res + _other -> Nothing postprocess :: [(ExamOccurrenceId, [[CI Char]])] -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) @@ -428,7 +459,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences ) postprocess result = (resultAscList, resultUsers) where - resultAscList = Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result where accRes _ [] = [] accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) @@ -445,13 +476,16 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , mayRange (succ $ length common) minB , firstA : _ <- suffA , firstB : _ <- suffB - -> let break' = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) - & floor - & Char.chr - & Char.toUpper - & CI.mk - & pure - & (common ++) + -> let break' + | occSize occA > 0 || occSize occB > 0 + = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) + & floor + & Char.chr + & Char.toUpper + & CI.mk + & pure + & (common ++) + | otherwise = common ++ pure (CI.mk firstA) succBreak = fmap reverse . go $ reverse break' where go [] = Nothing @@ -478,7 +512,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) resultUsers = Map.fromList $ do (occId, buckets) <- result - user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b == b') $ Map.toList users') buckets + let matchWord b b' = case rule of + ExamRoomMatriculation + -> b `isSuffixOf` b' + _other + -> b == b' + user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets return (user, Just occId) occSize :: Num a => ExamOccurrenceId -> a @@ -494,3 +533,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences = mempty mayRange :: Int -> [CI Char] -> Bool mayRange l = all (`Set.member` rangeAlphabet) . take l + + pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) + pad res + | ExamRoomMatriculation <- rule + , Just minAlpha <- Set.lookupMin rangeAlphabet + = let maxLength = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length + padSuff cs = replicate (maxLength - length cs) minAlpha ++ cs + in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res + | otherwise + = res diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index 36f99950e..78cdf5b13 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -29,8 +29,8 @@ $newline never _{examOccurrenceName}

        		_{loadProp (occLoad occId) examOccurrenceCapacity} - $maybe mappingWgt <- occMapping occId - + + $maybe mappingWgt <- occMapping occId ^{mappingWgt} #{examOccurrenceRoom} From 91e1bf99966655b0a8f7ab99d0ddebe5642c627b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 13:15:59 +0100 Subject: [PATCH 22/31] feat: warnings about multiple terms/schools --- messages/uniworx/de-de-formal.msg | 2 ++ messages/uniworx/en-eu.msg | 2 ++ src/Handler/Course/Edit.hs | 27 +++++++++++++++++---------- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 7504c4f34..d7f784150 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -142,9 +142,11 @@ CourseDescriptionTip: Beliebiges Html-Markup ist gestattet CourseHomepageExternal: Externe Homepage CourseShorthand: Kürzel CourseShorthandUnique: Muss nur innerhalb Institut und Semester eindeutig sein. Wird verbatim in die Url der Kursseite übernommen. +CourseSemesterMultipleTip: Es stehen für Sie aktuell mehrere Semester zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Semester wählen. CourseSemester: Semester CourseSchool: Institut CourseSchoolShort: Institut +CourseSchoolMultipleTip: Es stehen für Sie mehrere Institute zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Institut wählen. CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden erlaubt. diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index db8199833..345fe2d08 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -142,9 +142,11 @@ CourseDescriptionTip: You may use arbitrary Html-Markup CourseHomepageExternal: External homepage CourseShorthand: Shorthand CourseShorthandUnique: Needs to be unique within school and semester. Will be used verbatim within the url of the course page. +CourseSemesterMultipleTip: You are currently allowed to select from among multiple semesters. Please ensure that you select the appropriate semester for your course. CourseSemester: Semester CourseSchool: Department CourseSchoolShort: Department +CourseSchoolMultipleTip: You may select from among multiple departments. Please ensure that you select the appropriate department for your course. CourseSecretTip: Enrollment for this course will require the password, if set CourseSecretFormat: Arbitrary string CourseRegisterFromTip: When left empty students will not be able to enrol themselves diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 9f5bc8c7f..2b1b2fa7e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -115,16 +115,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB return (lecturerSchools, adminSchools, oldSchool) let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools - termsField <- case template of - -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin - (Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course - _courseOld@Course{..} <- runDB $ get404 cid - mayEditTerm <- isAuthorized TermEditR True - mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True - return $ if - | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField - | otherwise -> termsSetField [cfTerm cform] - _allOtherCases -> return termsAllowedField + (termsField, userTerms) <- liftHandler $ case template of + -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + _courseOld@Course{..} <- runDB $ get404 cid + mayEditTerm <- isAuthorized TermEditR True + mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True + if + | (mayEditTerm == Authorized) || (mayDelete == Authorized) + -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] []) + | otherwise + -> return (termsSetField [cfTerm cform], [cfTerm cform]) + _allOtherCases -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] []) let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do @@ -258,13 +260,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB -- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|] + multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip + multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip + (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …" -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) + <* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) + <* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder) & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) From a1d547990df712f1866113dfeedc01d573d730c5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 13:33:02 +0100 Subject: [PATCH 23/31] fix(exams): exam-auto-occurrence introduced spurious MappingSpecial --- src/Handler/Utils/Exam.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 844919ed2..205e0f94c 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -197,7 +197,7 @@ data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig instance Default ExamAutoOccurrenceConfig where def = ExamAutoOccurrenceConfig { eaocMinimizeRooms = False - , eaocFinenessCost = 0.2 + , eaocFinenessCost = 0.1 } makeLenses_ ''ExamAutoOccurrenceConfig @@ -467,7 +467,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , Just maxA <- nsA ^? _last , Just minB <- nsB ^? _head = let common = maxA `lcp` minB - mayRange' = mayRange . max 1 . succ $ length common suffA = CI.foldedCase <$> drop (length common) maxA suffB = CI.foldedCase <$> drop (length common) minB in if @@ -495,9 +494,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences = Just $ c' : cs | otherwise = go cs - in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) . Set.filter (not . mayRange') $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) + commonLength = max 1 . succ . length $ minA `lcp` break' + in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) | otherwise - -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) + -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) | null nsA = accRes prevEnd $ (occB, nsB) : xs | otherwise -- null nsB @@ -506,7 +506,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | Just minAlpha <- Set.lookupMin rangeAlphabet , Just maxAlpha <- Set.lookupMax rangeAlphabet , minZ <- fromMaybe (pure minAlpha) prevEnd - = let commonLength = max 1 $ length minZ + = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ) | otherwise = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) From d90d8e1af3b31441e3cf5f4b808f828d3c2388a6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 13:35:44 +0100 Subject: [PATCH 24/31] chore: bump changelog --- templates/i18n/changelog/de-de-formal.hamlet | 13 ++++++++++++- templates/i18n/changelog/en-eu.hamlet | 13 ++++++++++++- 2 files changed, 24 insertions(+), 2 deletions(-) diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index e7a030b42..470fb8e55 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,11 +1,22 @@ $newline never
        +
        + ^{formatGregorianW 2020 01 30} +
        +
          +
        • + Verbesserung bei der Darstellung von Zuteilungsregeln nach der # + automatischen Verteilung von Klausurteilnehmern +
        • + Warnungen beim anlegen von Kursen, die auf mehrere zur Auswahl # + stehende Semester/Institute hinweisen +
          ^{formatGregorianW 2020 01 29}
          • - Automatische Verteilung von Klausurteilnehmern auf + Automatische Verteilung von Klausurteilnehmern auf # Termine/Räume
            diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index 795925a95..85999caea 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -1,11 +1,22 @@ $newline never
            +
            + ^{formatGregorianW 2020 01 30} +
            +
              +
            • + Improvements in display of assignment rules after automated # + distribution of exam participants +
            • + Display of a warning if multiple semesters/departments are # + available when creating a course +
              ^{formatGregorianW 2020 01 29}
              • - Automated distribution of exam participants over configured + Automated distribution of exam participants over configured # occurrences/rooms
                From 0af3b87a474544231f8c277ed2fdb421aabfe86a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 13:38:04 +0100 Subject: [PATCH 25/31] fix: date formatting --- templates/i18n/data-protection/de-de-formal.hamlet | 4 ++-- templates/i18n/data-protection/en.hamlet | 4 ++-- templates/i18n/terms-of-use/de-de-formal.hamlet | 2 +- templates/i18n/terms-of-use/en.hamlet | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/templates/i18n/data-protection/de-de-formal.hamlet b/templates/i18n/data-protection/de-de-formal.hamlet index 8607f7d7b..b8fb7ea06 100644 --- a/templates/i18n/data-protection/de-de-formal.hamlet +++ b/templates/i18n/data-protection/de-de-formal.hamlet @@ -1,10 +1,10 @@ $newline never -Zuletzt geändert: 23.12.2019 +Zuletzt geändert: ^{formatGregorianW 2019 12 23}

                Die folgende Datenschutzerklärung erweitert die # Datenschutzerklärung der Rechnerbetriebsgruppe (RBG) der LMU # - der Version 0.91 vom 22.05.2018.
                + der Version 0.91 vom ^{formatGregorianW 2018 05 22}.
                Sollte obenstehender Link auf eine Datenschutzerklärung mit höherer Versionsnummer verweisen, # so ist im Falle widersprüchlicher Informationen die Fassung der RBG vorzuziehen.

                diff --git a/templates/i18n/data-protection/en.hamlet b/templates/i18n/data-protection/en.hamlet index c9e77cec5..85fa15fe9 100644 --- a/templates/i18n/data-protection/en.hamlet +++ b/templates/i18n/data-protection/en.hamlet @@ -1,10 +1,10 @@ $newline never -Last changed: 23.12.2019 +Last changed: ^{formatGregorianW 2019 12 23}

                The following data protection statement extends the # Data Protection Statement of the Rechnerbetriebsgruppe (RBG) of the LMU # - , Version 0.91 from 22.05.2018.
                + , Version 0.91 from ^{formatGregorianW 2018 05 22}.
                Should the Data Protection Statement linked above be newer than the Statement on this page, # the version of the RBG has higher priority than this version in case of conflicting information. diff --git a/templates/i18n/terms-of-use/de-de-formal.hamlet b/templates/i18n/terms-of-use/de-de-formal.hamlet index 0cf2861f4..73eef10b9 100644 --- a/templates/i18n/terms-of-use/de-de-formal.hamlet +++ b/templates/i18n/terms-of-use/de-de-formal.hamlet @@ -1,5 +1,5 @@ $newline never -Zuletzt geändert: 18.12.2019 +Zuletzt geändert: ^{formatGregorianW 2019 12 18}

                Die im Folgenden geführten Nutzungsbedingungen beziehen sich auf die unter der URL
                diff --git a/templates/i18n/terms-of-use/en.hamlet b/templates/i18n/terms-of-use/en.hamlet index 5a285bc8b..e7c4070f7 100644 --- a/templates/i18n/terms-of-use/en.hamlet +++ b/templates/i18n/terms-of-use/en.hamlet @@ -1,5 +1,5 @@ $newline never -Last changed: 18.12.2019 +Last changed: ^{formatGregorianW 2019 12 18}

                The following Terms of Use apply to the contents reachable via
                From fa7f63d8f76cc0943c1667a5276933e0f26d665d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 13:41:32 +0100 Subject: [PATCH 26/31] chore: bump knownBugs --- templates/i18n/knownBugs/de-de-formal.hamlet | 9 +++++++-- templates/i18n/knownBugs/en-eu.hamlet | 11 ++++++++--- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/templates/i18n/knownBugs/de-de-formal.hamlet b/templates/i18n/knownBugs/de-de-formal.hamlet index 6c3d7168d..45b074fc4 100644 --- a/templates/i18n/knownBugs/de-de-formal.hamlet +++ b/templates/i18n/knownBugs/de-de-formal.hamlet @@ -1,10 +1,15 @@ $newline never

                - Stand: Oktober 2019 + Stand: ^{formatGregorianW 2020 01 30}

                • Format von Bewertungsdateien ist noch provisorisch
                • - Zahlen und Prüfungsergebnisse werden nicht internationalisiert (betrifft auch CSV-Import und Export) + Zahlen und Prüfungsergebnisse werden nicht internationalisiert # + (betrifft auch CSV-Import und Export)
                • Feste (registrierte) Abgabegruppen sind noch nicht implementiert +
                • + Minimierung der Anzahl verwendeter Termine bei der automatischen # + Verteilung von Klausurteilnehmern produziert suboptimale # + Ergebnisse diff --git a/templates/i18n/knownBugs/en-eu.hamlet b/templates/i18n/knownBugs/en-eu.hamlet index 98d8fa483..ede33f3c0 100644 --- a/templates/i18n/knownBugs/en-eu.hamlet +++ b/templates/i18n/knownBugs/en-eu.hamlet @@ -1,10 +1,15 @@ $newline never

                  - Last updated: October 2019 + Last updated: ^{formatGregorianW 2020 01 30}

                  • Format of rating files is provisional
                  • - Numbers and exam results are not internationalised (also affects csv-import and export) + Numbers and exam results are not internationalised (also affects # + csv-import and export)
                  • - Fixed (registered) groups for exercise sheet submission not yet implemented + Fixed (registered) groups for exercise sheet submission not yet # + implemented +
                  • + Minimisation of number of rooms used when automatically # + distributing exam participants does not produce optimal results From a91fd7fd6387e82331d881ec32e830fd59634d9d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 17:24:22 +0100 Subject: [PATCH 27/31] feat: exam auto-occurrence nudging --- frontend/src/app.sass | 7 ++ messages/uniworx/de-de-formal.msg | 2 + messages/uniworx/en-eu.msg | 2 + src/Handler/Exam/AutoOccurrence.hs | 41 +++++++++- src/Handler/Utils/Exam.hs | 74 ++++++++++++------- src/Utils/Form.hs | 2 +- src/Utils/Parameters.hs | 1 + .../widgets/exam-occurrence-mapping.hamlet | 5 +- 8 files changed, 103 insertions(+), 31 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 9b842f8a2..b4acef15e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -249,6 +249,13 @@ button, box-shadow: 0 0 0 0.25rem rgba(50, 115, 220, 0.25) outline: 0 + .buttongroup > & + min-width: 0 + +.buttongroup + display: grid + grid: min-content / auto-flow 1fr + input[type="submit"][disabled], input[type="button"][disabled], button[disabled], diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d7f784150..ebff2b149 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2285,6 +2285,8 @@ ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raum-/Terminverteilung BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen BtnExamAutoOccurrenceAccept: Verteilung akzeptieren +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Nachnamen beginnend mit ExamRoomMappingMatriculation: Matrikelnummern endend in ExamRoomLoad: Auslastung \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 345fe2d08..b26b66919 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2284,6 +2284,8 @@ ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule save TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution BtnExamAutoOccurrenceCalculate: Calculate assignment rules BtnExamAutoOccurrenceAccept: Accept assignments +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Surnames starting with ExamRoomMappingMatriculation: Matriculation numbers ending in ExamRoomLoad: Utilisation \ No newline at end of file diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 925df22fd..222fd7896 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -18,7 +18,9 @@ import Database.Persist.Sql (updateWhereCount) newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm { eaofConfig :: ExamAutoOccurrenceConfig } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Default) + deriving newtype (Default, FromJSON, ToJSON) + +makeLenses_ ''ExamAutoOccurrenceCalculateForm data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) @@ -32,6 +34,7 @@ deriveJSON defaultOptions data ExamAutoOccurrenceButton = BtnExamAutoOccurrenceCalculate | BtnExamAutoOccurrenceAccept + | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamAutoOccurrenceButton instance Finite ExamAutoOccurrenceButton @@ -40,6 +43,8 @@ nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id instance Button UniWorX ExamAutoOccurrenceButton where + btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton] + btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton] btnClasses _ = [BCIsButton, BCPrimary] @@ -51,6 +56,23 @@ examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) <*> pure def +examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceNudgeForm occId protoForm html = do + cID <- encrypt occId + (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html + oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField + oldDataId <- newIdent + + let protoForm' = fromMaybe def $ oldDataRes <|> protoForm + genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n + where n = case btn of + BtnExamAutoOccurrenceNudgeUp -> 1 + BtnExamAutoOccurrenceNudgeDown -> -1 + _other -> 0 + res = genForm <$> btnRes + oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False + return (res, wgt <> oldDataView) + examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData @@ -78,7 +100,14 @@ postEAutoOccurrenceR tid ssh csh examn = do ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def - calcResult <- formResultMaybe calculateRes $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do + nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> + runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes) + + let calculateRes' = asum $ + [ calculateRes + ] ++ toListOf (folded . _1 . _1) nudgeRes + + calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId @@ -114,6 +143,14 @@ postEAutoOccurrenceR tid ssh csh examn = do addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount redirect $ CExamR tid ssh csh examn EUsersR + let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) -> + wrapForm nudgeView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = nudgeEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup")] + } + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult let heading = MsgTitleExamAutoOccurrence tid ssh csh examn diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 205e0f94c..129d11b7e 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,11 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade , ExamAutoOccurrenceConfig - , eaocMinimizeRooms, eaocFinenessCost - , _eaocMinimizeRooms, _eaocFinenessCost + , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize + , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize , examAutoOccurrence ) where @@ -192,15 +194,23 @@ examGrade Exam{..} mBonus (otoList -> results) data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig { eaocMinimizeRooms :: Bool , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms + , eaocNudge :: Map ExamOccurrenceId Integer + , eaocNudgeSize :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default ExamAutoOccurrenceConfig where def = ExamAutoOccurrenceConfig { eaocMinimizeRooms = False - , eaocFinenessCost = 0.1 + , eaocFinenessCost = 0.2 + , eaocNudge = Map.empty + , eaocNudgeSize = 0.05 } makeLenses_ ''ExamAutoOccurrenceConfig + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceConfig examAutoOccurrence :: forall seed. @@ -283,9 +293,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences distribute :: forall wordId lineId cost. _ - => [(wordId, Natural)] - -> [(lineId, Natural)] - -> (wordId -> wordId -> Extended Rational) + => [(wordId, Natural)] -- ^ Word sizes (in order) + -> [(lineId, Natural)] -- ^ Line sizes (in order) + -> (lineId -> Integer) -- ^ Nudge + -> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> Maybe (cost, [(lineId, [wordId])]) -- ^ Distribute the given items (@wordId@s) with associated size in -- contiguous blocks into the given buckets (@lineId@s) such that they are @@ -294,7 +305,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences -- Return a cost scaled to item-size squared -- -- See under \"Shortest Path\" - distribute wordLengths lineLengths breakCost + distribute wordLengths lineLengths lineNudge breakCost | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ]) | null lineLengths = Nothing | otherwise = let (cost, result) = distribute' @@ -347,15 +358,15 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences walkBack 0 = return 0 walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' lineIx <- walkBack i - let potWidth + let (l, potWidth) | lineIx >= 0 , lineIx < length lineLengths - = view _2 $ lineLengths List.!! lineIx + = over _1 Just $ lineLengths List.!! lineIx | otherwise - = 0 + = (Nothing, 0) w = offsets Array.! j - offsets Array.! i prevMin <- ST.readArray minima i - let cost = prevMin + widthCost potWidth w + breakCost' + let cost = prevMin + widthCost l potWidth w + breakCost' breakCost' | j < Map.size wordMap , j > 0 @@ -393,12 +404,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences in accumResult 0 (Map.size wordMap) (0, []) - widthCost :: Natural -> Natural -> Extended Rational - widthCost lineWidth w + widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational + widthCost l lineWidth w | lineWidth < w = PosInf - | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio) * fromIntegral longestLine) ^ 2 + | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2 where optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio charCost :: [CI Char] -> [CI Char] -> Extended Rational charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 @@ -414,10 +426,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | a == b = a:lcp as bs | otherwise = [] + lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge + bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of ExamRoomSurname -> do - (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost -- traceM $ show cost return res ExamRoomMatriculation -> do @@ -425,7 +439,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' distributeFine :: Natural -> Maybe (Extended Rational, _) - distributeFine n = distribute (usersFineness n) occurrences' charCost + distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' @@ -459,7 +473,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences ) postprocess result = (resultAscList, resultUsers) where - resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result where accRes _ [] = [] accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) @@ -467,14 +481,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , Just maxA <- nsA ^? _last , Just minB <- nsB ^? _head = let common = maxA `lcp` minB - suffA = CI.foldedCase <$> drop (length common) maxA - suffB = CI.foldedCase <$> drop (length common) minB in if - | mayRange (succ $ length common) maxA - , mayRange (succ $ length common) minA - , mayRange (succ $ length common) minB - , firstA : _ <- suffA - , firstB : _ <- suffB + | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last + , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head + , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head + , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA + , firstB : _ <- CI.foldedCase <$> drop (length common) rminB -> let break' | occSize occA > 0 || occSize occB > 0 = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) @@ -495,9 +507,14 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | otherwise = go cs commonLength = max 1 . succ . length $ minA `lcp` break' - in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) + isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA ) + isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break') + rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA + breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA + breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA + in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs) | otherwise - -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) + -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs) | null nsA = accRes prevEnd $ (occB, nsB) : xs | otherwise -- null nsB @@ -507,7 +524,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , Just maxAlpha <- Set.lookupMax rangeAlphabet , minZ <- fromMaybe (pure minAlpha) prevEnd = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ - in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ) + isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ) + rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ + breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ + in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials) | otherwise = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) resultUsers = Map.fromList $ do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4b12d47b4..78af6cfaf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,7 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDAllUsersAction | FIDLanguage - | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 96fe65fd9..f78926740 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -57,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier | PostBearer | PostDBCsvImportAction | PostLoginDummy + | PostExamAutoOccurrencePrevious deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index 78cdf5b13..a3c8b8ef0 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -4,7 +4,7 @@ $newline never
        _{MsgExamRoomName} - + _{MsgExamRoomLoad} $maybe rule <- occMappingRule $case rule @@ -29,6 +29,9 @@ $newline never _{examOccurrenceName} _{loadProp (occLoad occId) examOccurrenceCapacity} + + $maybe nudgeWgt' <- Map.lookup occId nudgeWgt + ^{nudgeWgt'} $maybe mappingWgt <- occMapping occId ^{mappingWgt} From e2c664d7d4b72beeef3eedb4520e4599e20e670c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 17:38:01 +0100 Subject: [PATCH 28/31] refactor: hlint --- src/Handler/Exam/AutoOccurrence.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 222fd7896..6354b2dcd 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -103,9 +103,7 @@ postEAutoOccurrenceR tid ssh csh examn = do nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes) - let calculateRes' = asum $ - [ calculateRes - ] ++ toListOf (folded . _1 . _1) nudgeRes + let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do From 2e6b1d6a84bfa1c848afc1a97b4d57d6fb86f5aa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 17:41:10 +0100 Subject: [PATCH 29/31] Revert "chore(gitlab-ci): disable resource_group due to gitlab version" This reverts commit 45506bd7736256058d20fc098727d36286f1d410. --- .gitlab-ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b7ec49c62..97f40010b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -136,7 +136,7 @@ yesod:build: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - # resource_group: ram + resource_group: ram frontend:test: stage: test @@ -220,7 +220,7 @@ hlint: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - # resource_group: ram + resource_group: ram yesod:test: services: @@ -245,7 +245,7 @@ yesod:test: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 interruptible: true - # resource_group: ram + resource_group: ram deploy:uniworx3: stage: deploy @@ -267,4 +267,4 @@ deploy:uniworx3: only: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ - # resource_group: uniworx3 + resource_group: uniworx3 From 4519d18d0791a11430762537ff9ce1d4ef93c7ab Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 17:43:23 +0100 Subject: [PATCH 30/31] chore(release): 10.6.0 --- CHANGELOG.md | 18 ++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 21 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e842425f3..c8dd6fa28 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. +## [10.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.5.0...v10.6.0) (2020-01-30) + + +### Bug Fixes + +* date formatting ([0af3b87](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0af3b87)) +* **exams:** exam-auto-occurrence introduced spurious MappingSpecial ([a1d5479](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1d5479)) +* exam auto-occurrence by matriculation ([3ef10d9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ef10d9)) +* non-exhaustive patterns ([5bff34e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bff34e)) + + +### Features + +* exam auto-occurrence nudging ([a91fd7f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a91fd7f)) +* warnings about multiple terms/schools ([91e1bf9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/91e1bf9)) + + + ## [10.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.1...v10.5.0) (2020-01-29) diff --git a/package-lock.json b/package-lock.json index 532f16452..72157cdb6 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "10.5.0", + "version": "10.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 5a2e33339..f8c22b86a 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "10.5.0", + "version": "10.6.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f664132c4..c7001df09 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 10.5.0 +version: 10.6.0 dependencies: - base From e7ff3846f2b758e6fa1c10a5157eef1747750d38 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 3 Feb 2020 13:48:38 +0100 Subject: [PATCH 31/31] fix: do not apply target link height fix on targets in tables --- frontend/src/app.sass | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index b4acef15e..2568a5dbb 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -164,7 +164,7 @@ h4 margin-top: var(--current-header-height) margin-left: 0 - :target::before + :target:not(table :target)::before content: "" display: block height: var(--current-header-height)