diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 64bbcad6f..0378a8cee 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -25,12 +25,17 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Experimental as Ex +import qualified Database.Esqueleto.Utils as Ex import qualified Control.Monad.State.Class as State import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Pandoc.Shared (toRomanNumeral) +import qualified Data.Char as Char +import qualified Data.Text as Text import qualified Data.Text.Lazy as LT +import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.Combinators as C @@ -63,7 +68,7 @@ data ExamForm = ExamForm data ExamOccurrenceForm = ExamOccurrenceForm { eofId :: Maybe CryptoUUIDExamOccurrence - , eofName :: ExamOccurrenceName + , eofName :: Maybe ExamOccurrenceName , eofExaminer :: Maybe UserId , eofRoom :: Maybe RoomReference , eofRoomHidden :: Bool @@ -256,7 +261,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do examOccurrenceForm :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm examOccurrenceForm nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) - (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev) + (eofNameRes, eofNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev) (eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions! (eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,) <$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev) @@ -310,39 +315,92 @@ examOccurrenceMultiForm prev = wFormToAForm $ do miIdent' :: Text miIdent' = "exam-occurrences" --- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB () -- to specific -upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm, - PersistStoreWrite backend, MonadHandler m, BaseBackend backend ~ SqlBackend, HandlerSite m ~ UniWorX) +-- | generate an exam-unique occurrence name from data +-- Pattern: ___ +-- eofName is entirely ignored, assumed to be Nothing +guessExamOccurrenceName :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend, MonadHandler m, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend, HandlerSite m ~ UniWorX, MonadThrow m) + => Key Exam -> ExamOccurrenceForm -> ReaderT backend m ExamOccurrenceName +guessExamOccurrenceName eId ExamOccurrenceForm{..} = do + -- oday <- formatTime' "%m-%d" eofStart + oday <- formatTime' "%d.%m." eofStart + ohour <- ifM hasMoreThanOneHour (formatTime' "at%H" eofStart) (return mempty) + inis <- ifMoreThanOne ExamOccurrenceExaminer $ foldMapM getInitials eofExaminer + room <- case eofRoom of + Just (RoomReferenceSimple t) -> ifMoreThanOne ExamOccurrenceRoom $ return $ Text.take 4 t -- Text.cons '-' $ Text.take 4 t + _ -> return mempty + let pfx = CI.mk $ inis <> oday <> ohour <> room + eons = ocheck pfx : [ ocheck $ pfx <> CI.mk (Text.cons '_' $ toRomanNumeral n) | n <- [2..3999]] + fromMaybe "Handler.Exam.Form.guessExamOccurrenceName failed to guess a unique name" + <$> firstJustM eons + where + getInitials uid = get uid <&> foldMap (Text.filter Char.isUpper . userDisplayName) -- flip Text.snoc '_' . + ocheck eon = existsBy (UniqueExamOccurrence eId eon) <&> (flip toMaybe eon . not) + + ifMoreThanOne :: (PersistField t, Monoid o) => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m o -> ReaderT backend m o + ifMoreThanOne eoprop act = ifM (hasMoreThanOne eoprop) act (return mempty) + + hasMoreThanOne :: PersistField t => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m Bool + hasMoreThanOne eoprop = $(memcachedByHere) (Just . Right $ 1 * diffMinute) (eId, tshow $ persistFieldDef eoprop) $ Ex.selectExists $ do + exOcc <- Ex.from $ Ex.table @ExamOccurrence + Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId) + Ex.&&. Ex.isJust (exOcc Ex.^. eoprop) + Ex.&&. Ex.exists (do + otOcc <- Ex.from $ Ex.table @ExamOccurrence + Ex.where_ $ (otOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId) + Ex.&&. Ex.isJust (otOcc Ex.^. eoprop) + Ex.&&. otOcc Ex.^. eoprop Ex.!=. exOcc Ex.^. eoprop + ) + + hasMoreThanOneHour :: ReaderT backend m Bool + hasMoreThanOneHour = $(memcachedByHere) (Just . Right $ 1 * diffMinute) eId $ Ex.selectExists $ do + exOcc <- Ex.from $ Ex.table @ExamOccurrence + Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId) + Ex.&&. Ex.exists (do + other <- Ex.from $ Ex.table @ExamOccurrence + Ex.where_ $ (other Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId) + Ex.&&. (Ex.day (other Ex.^. ExamOccurrenceStart) Ex.==. Ex.day (exOcc Ex.^. ExamOccurrenceStart)) + Ex.&&. ( other Ex.^. ExamOccurrenceStart Ex.!=. exOcc Ex.^. ExamOccurrenceStart) + ) + + +-- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB () -- too specific +upsertExamOccurrences :: ( MonoFoldable mono, Element mono ~ ExamOccurrenceForm, HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m + , PersistQueryRead backend, PersistUniqueRead backend, PersistStoreWrite backend + , BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend) => Key Exam -> mono -> ReaderT backend m () upsertExamOccurrences eId = mapM_ $ \case - ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ - ExamOccurrence - { examOccurrenceExam = eId - , examOccurrenceName = eofName - , examOccurrenceExaminer = eofExaminer - , examOccurrenceRoom = eofRoom - , examOccurrenceRoomHidden = eofRoomHidden - , examOccurrenceCapacity = eofCapacity - , examOccurrenceStart = eofStart - , examOccurrenceEnd = eofEnd - , examOccurrenceDescription = eofDescription - } - ExamOccurrenceForm{ .. } -> void . runMaybeT $ do - cID <- hoistMaybe eofId - eofId' <- decrypt cID - oldOcc <- MaybeT $ get eofId' - guard $ examOccurrenceExam oldOcc == eId - lift $ replace eofId' ExamOccurrence - { examOccurrenceExam = eId - , examOccurrenceName = eofName - , examOccurrenceExaminer = eofExaminer - , examOccurrenceRoom = eofRoom - , examOccurrenceRoomHidden = eofRoomHidden - , examOccurrenceCapacity = eofCapacity - , examOccurrenceStart = eofStart - , examOccurrenceEnd = eofEnd - , examOccurrenceDescription = eofDescription - } + eof@ExamOccurrenceForm{ eofId = Nothing, eofName = eofNameMb, .. } -> do + eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb) + $logInfoS "ExamOccurrenceForm" [st|New Exam Occurrence: #{eofName}|] + insert_ ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceName = eofName + , examOccurrenceExaminer = eofExaminer + , examOccurrenceRoom = eofRoom + , examOccurrenceRoomHidden = eofRoomHidden + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } + eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> void . runMaybeT $ do + cID <- hoistMaybe eofId + eofId' <- decrypt cID + oldOcc <- MaybeT $ get eofId' + guard $ examOccurrenceExam oldOcc == eId + lift $ do + eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb) + replace eofId' ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceName = eofName + , examOccurrenceExaminer = eofExaminer + , examOccurrenceRoom = eofRoom + , examOccurrenceRoomHidden = eofRoomHidden + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm prev = wFormToAForm $ do @@ -420,7 +478,7 @@ examFormTemplate (Entity eId Exam{..}) = do (Just -> eofId, ExamOccurrence{..}) <- occurrences' return ExamOccurrenceForm { eofId - , eofName = examOccurrenceName + , eofName = examOccurrenceName & Just , eofExaminer = examOccurrenceExaminer , eofRoom = examOccurrenceRoom , eofRoomHidden = examOccurrenceRoomHidden @@ -524,10 +582,10 @@ validateExam cId oldExam = do guardValidation MsgExamPartsFromMustBeBeforeFinished $ NTop efFinished >= NTop efPartsFrom || is _Nothing efPartsFrom - forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do - guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) + forM_ efOccurrences $ \ExamOccurrenceForm{eofName=fold->eofName, ..} -> do + guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart - warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + warnValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) @@ -540,7 +598,7 @@ validateExam cId oldExam = do , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription ] - guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b + guardValidation (MsgExamOccurrenceDuplicateName $ fold $ eofName a) $ ((/=) `on` eofName) a b oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index d3cc42690..479002ce9 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -70,19 +70,7 @@ postCExamNewR tid ssh csh = do examPartWeight = epfWeight ] - insertMany_ - [ ExamOccurrence{..} - | ExamOccurrenceForm{..} <- Set.toList efOccurrences - , let examOccurrenceExam = examid - examOccurrenceName = eofName - examOccurrenceExaminer = eofExaminer - examOccurrenceRoom = eofRoom - examOccurrenceRoomHidden = eofRoomHidden - examOccurrenceCapacity = eofCapacity - examOccurrenceStart = eofStart - examOccurrenceEnd = eofEnd - examOccurrenceDescription = eofDescription - ] + upsertExamOccurrences examid efOccurrences insertMany_ [ ExamOfficeSchool ssh' examid | ssh' <- Set.toList efOfficeSchools ] diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index ffddc9fa9..508edd33f 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -57,7 +57,7 @@ mkExamOccurrenceForm exs eom = renderAForm FormStandard maa <*> apreq hiddenField "" (Just cueId) <*> apreq (mkSetField hiddenField) "" cuEoIds <* aformInfoWidget ewgt - <*> examOccurrenceMultiForm eos + <*> examOccurrenceMultiForm eos -- TODO filter occurrences to cuEoIds ) data TutorialUserAction diff --git a/src/Handler/Utils/Course/Cache.hs b/src/Handler/Utils/Course/Cache.hs index fb1c97abb..63e0a0d0c 100644 --- a/src/Handler/Utils/Course/Cache.hs +++ b/src/Handler/Utils/Course/Cache.hs @@ -176,7 +176,7 @@ convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm { eofId = Just cueoId - , eofName = examOccurrenceName + , eofName = Just examOccurrenceName , eofExaminer = examOccurrenceExaminer , eofRoom = examOccurrenceRoom , eofRoomHidden = examOccurrenceRoomHidden diff --git a/src/Utils.hs b/src/Utils.hs index a1044b82d..e9bc38dee 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1020,7 +1020,7 @@ positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act --- maybeEmptyM, maybeNotingM +-- maybeEmptyM, maybeNothingM traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b) traverseJoin f x = join <$> (f `traverse` x) @@ -1150,12 +1150,6 @@ firstJustM = Fold.foldr go (return Nothing) go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) go n p = n >>= \case {Nothing -> p; res -> return res} --- firstJustM1 :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) => mono -> m (Maybe a) --- firstJustM1 = foldr go (return Nothing) --- where --- go n p = n >>= \case {Nothing -> p; res -> return res} - - -- | Run the maybe computation repeatedly until the first Just is returned -- or the number of maximum retries is exhausted. -- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.