chore(exam): auto name generation for examOccurrences
This commit is contained in:
parent
f04a40c0a3
commit
f996976f65
@ -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: <initials-examiner>_<mm-dd>_<room>_<roman_numeral>
|
||||
-- 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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user