Merge branch 'master' into stundenplan
This commit is contained in:
Sarah Vaupel
commit
304a60560d
@ -1975,6 +1975,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Te
|
||||
ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} liegt nach dem Ende der Prüfung
|
||||
ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
|
||||
ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor
|
||||
ExamOccurrenceCannotBeDeletedDueToRegistrations eoName@ExamOccurrenceName: Termin #{eoName} kann nicht gelöscht werden, da noch Teilnehmer diesem Termin zugewiesen sind. Über die Liste von Prüfungsteilnehmern können Sie zunächst die entsprechenden Terminzuweisungen entfernen.
|
||||
ExamPartCannotBeDeletedDueToResults exampartnum@ExamPartNumber: Teil #{exampartnum} kann nicht gelöscht werden, da bereits Prüfungsergebnisse für diesen Teil eingetragen wurden.
|
||||
|
||||
VersionHistory: Versionsgeschichte
|
||||
KnownBugs: Bekannte Bugs
|
||||
|
||||
@ -1974,6 +1974,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName
|
||||
ExamOccurrenceEndMustBeBeforeExamEnd eoName: End of the occurrence #{eoName} must be before the exam end
|
||||
ExamOccurrenceDuplicate eoRoom eoRange: Combination of room #{eoRoom} and occurrence #{eoRange} occurs multiple times
|
||||
ExamOccurrenceDuplicateName eoName: Internal name #{eoName} occurs multiple times
|
||||
ExamOccurrenceCannotBeDeletedDueToRegistrations eoName: Occurrence #{eoName} cannot be deleted because participants are registered for it. You can remove the offending registrations via the list of exam participants.
|
||||
ExamPartCannotBeDeletedDueToResults exampartnum: Part #{exampartnum} cannot be deleted because some exam part results were already entered for it.
|
||||
|
||||
VersionHistory: Version history
|
||||
KnownBugs: Known bugs
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
import ((nixpkgs {}).fetchFromGitHub {
|
||||
owner = "NixOS";
|
||||
repo = "nixpkgs";
|
||||
rev = "bc00ecedfa709f4fa91d445dd76ecd792cb2c728";
|
||||
sha256 = "0plhwb04srr4b0h7w8qlqi207a19szz2wqz6r4gmic856jlkchaa";
|
||||
rev = "a7a1447e5d40a9ad90983d33e151f5474eddeed9";
|
||||
sha256 = "1zb8wgsq9grrsdcz81y08h45rj8i5r8ckjhg2cv1cqmam4dczcrf";
|
||||
fetchSubmodules = true;
|
||||
})
|
||||
|
||||
@ -18,17 +18,14 @@ import Jobs.Queue
|
||||
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEEditR = postEEditR
|
||||
postEEditR tid ssh csh examn = do
|
||||
(cid, Entity eId oldExam, template) <- runDB $ do
|
||||
(cid, exam) <- fetchCourseIdExam tid ssh csh examn
|
||||
(template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do
|
||||
(cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn
|
||||
|
||||
template <- examFormTemplate exam
|
||||
|
||||
return (cid, exam, template)
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm $ Just template
|
||||
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template
|
||||
|
||||
formResult editExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- myReplaceUnique eId Exam
|
||||
{ examCourse = cid
|
||||
, examName = efName
|
||||
@ -116,13 +113,15 @@ postEEditR tid ssh csh examn = do
|
||||
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
|
||||
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
||||
|
||||
return insertRes
|
||||
return . Just $ case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Nothing -> do
|
||||
addMessageI Success $ MsgExamEdited efName
|
||||
redirect $ CExamR tid ssh csh efName EShowR
|
||||
|
||||
case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Nothing -> do
|
||||
addMessageI Success $ MsgExamEdited efName
|
||||
redirect $ CExamR tid ssh csh efName EShowR
|
||||
return (template, (editExamAct, (editExamWidget, editExamEnctype)))
|
||||
|
||||
sequence_ editExamAct
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
|
||||
|
||||
|
||||
@ -98,11 +98,14 @@ deriveJSON defaultOptions
|
||||
} ''ExamOccurrenceForm
|
||||
|
||||
|
||||
examForm :: Maybe ExamForm -> Form ExamForm
|
||||
examForm template html = do
|
||||
examForm :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
|
||||
examForm template csrf = hoist liftHandler $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
flip (renderAForm FormStandard) html $ ExamForm
|
||||
flip (renderAForm FormStandard) csrf $ ExamForm
|
||||
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
|
||||
<*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template)
|
||||
<* aformSection MsgExamFormTimes
|
||||
@ -284,7 +287,11 @@ examPartsForm prev = wFormToAForm $ do
|
||||
miIdent' :: Text
|
||||
miIdent' = "exam-parts"
|
||||
|
||||
examFormTemplate :: Entity Exam -> DB ExamForm
|
||||
examFormTemplate :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> Entity Exam -> SqlPersistT m ExamForm
|
||||
examFormTemplate (Entity eId Exam{..}) = do
|
||||
examParts <- selectList [ ExamPartExam ==. eId ] []
|
||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
||||
@ -342,7 +349,8 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
, efStaff = examStaff
|
||||
}
|
||||
|
||||
examTemplate :: CourseId -> DB (Maybe ExamForm)
|
||||
examTemplate :: MonadHandler m
|
||||
=> CourseId -> SqlPersistT m (Maybe ExamForm)
|
||||
examTemplate cid = runMaybeT $ do
|
||||
newCourse <- MaybeT $ get cid
|
||||
|
||||
@ -393,7 +401,12 @@ examTemplate cid = runMaybeT $ do
|
||||
}
|
||||
|
||||
|
||||
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m ()
|
||||
validateExam :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) ()
|
||||
validateExam cId oldExam = do
|
||||
ExamForm{..} <- State.get
|
||||
|
||||
@ -404,6 +417,7 @@ validateExam cId oldExam = do
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
||||
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
|
||||
@ -421,6 +435,28 @@ validateExam cId oldExam = do
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicateName $ 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
|
||||
E.where_ . E.exists . E.from $ \examRegistration ->
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
|
||||
return ( examOccurrence E.^. ExamOccurrenceId
|
||||
, examOccurrence E.^. ExamOccurrenceName
|
||||
)
|
||||
forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) ->
|
||||
guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId
|
||||
|
||||
|
||||
oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do
|
||||
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
|
||||
E.where_ . E.exists . E.from $ \examPartResult ->
|
||||
E.where_ $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
|
||||
return ( examPart E.^. ExamPartId
|
||||
, examPart E.^. ExamPartNumber
|
||||
)
|
||||
forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) ->
|
||||
guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId
|
||||
|
||||
|
||||
mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
||||
E.where_ $ course E.^. CourseId E.==. E.val cId
|
||||
@ -429,7 +465,7 @@ validateExam cId oldExam = do
|
||||
whenIsJust mSchool $ \(Entity _ School{..}) -> do
|
||||
whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
|
||||
let doValidation
|
||||
| Just Exam{..} <- oldExam
|
||||
| Just (Entity _ Exam{..}) <- oldExam
|
||||
, not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
|
||||
= warnValidation
|
||||
| otherwise
|
||||
@ -438,7 +474,7 @@ validateExam cId oldExam = do
|
||||
. fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
|
||||
whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
|
||||
let doValidation
|
||||
| Just Exam{..} <- oldExam
|
||||
| Just (Entity _ Exam{..}) <- oldExam
|
||||
, not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
|
||||
= warnValidation
|
||||
| otherwise
|
||||
@ -447,7 +483,7 @@ validateExam cId oldExam = do
|
||||
. fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
|
||||
when schoolExamRequireModeForRegistration $ do
|
||||
let doValidation
|
||||
| Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam
|
||||
| Just (Entity _ Exam{ examExamMode = ExamMode{..}, .. }) <- oldExam
|
||||
, or [ is _Nothing examAids
|
||||
, is _Nothing examOnline
|
||||
, is _Nothing examSynchronicity
|
||||
@ -468,5 +504,5 @@ validateExam cId oldExam = do
|
||||
|
||||
warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode
|
||||
|
||||
unless (has (_Just . _examStaff . _Nothing) oldExam) $
|
||||
unless (has (_Just . _entityVal . _examStaff . _Nothing) oldExam) $
|
||||
guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff
|
||||
|
||||
@ -19,15 +19,13 @@ import qualified Data.Conduit.Combinators as C
|
||||
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamNewR = postCExamNewR
|
||||
postCExamNewR tid ssh csh = do
|
||||
(cid, template) <- runDB $ do
|
||||
(newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
template <- examTemplate cid
|
||||
return (cid, template)
|
||||
|
||||
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
|
||||
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
|
||||
|
||||
formResult newExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
insertRes <- insertUnique Exam
|
||||
@ -95,12 +93,15 @@ postCExamNewR tid ssh csh = do
|
||||
audit $ TransactionExamResultEdit examid courseParticipantUser
|
||||
runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
|
||||
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Just _ -> do
|
||||
addMessageI Success $ MsgExamCreated efName
|
||||
redirect $ CourseR tid ssh csh CExamListR
|
||||
return . Just $ case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgExamNameTaken efName
|
||||
Just _ -> do
|
||||
addMessageI Success $ MsgExamCreated efName
|
||||
redirect $ CourseR tid ssh csh CExamListR
|
||||
|
||||
return (newExamAct, (newExamWidget, newExamEnctype))
|
||||
|
||||
sequence_ newExamAct
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgExamNew
|
||||
|
||||
|
||||
12
src/Utils.hs
12
src/Utils.hs
@ -810,14 +810,14 @@ and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
|
||||
and2M ma mb = ifM ma mb (return False)
|
||||
or2M ma = ifM ma (return True)
|
||||
|
||||
andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
|
||||
andM = Fold.foldr and2M (return True)
|
||||
orM = Fold.foldr or2M (return False)
|
||||
andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool
|
||||
andM = ofoldl' and2M (return True)
|
||||
orM = ofoldl' or2M (return False)
|
||||
|
||||
-- | Short-circuiting monady any
|
||||
allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
|
||||
allM xs f = andM $ fmap f xs
|
||||
anyM xs f = orM $ fmap f xs
|
||||
allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool
|
||||
allM xs f = andM . fmap f $ otoList xs
|
||||
anyM xs f = orM . fmap f $ otoList xs
|
||||
|
||||
ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
|
||||
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Utils.Files
|
||||
( sinkFile, sinkFiles
|
||||
, sinkFile', sinkFiles'
|
||||
@ -35,6 +37,8 @@ import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Data.Conduit.Algorithms.FastCDC (fastCDC)
|
||||
|
||||
import Control.Monad.Trans.Cont
|
||||
|
||||
|
||||
sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX)
|
||||
=> Bool -- ^ Replace? Use only in serializable transaction
|
||||
@ -43,14 +47,16 @@ sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnlif
|
||||
sinkFileDB doReplace fileContentContent = do
|
||||
chunkingParams <- getsYesod $ view _appFileChunkingParams
|
||||
|
||||
let sinkChunk fileContentChunkContent = do
|
||||
let sinkChunk !fileContentChunkContent = do
|
||||
fileChunkLockTime <- liftIO getCurrentTime
|
||||
fileChunkLockInstance <- getsYesod appInstanceID
|
||||
|
||||
observeSunkChunk StorageDB $ olength fileContentChunkContent
|
||||
|
||||
tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. }
|
||||
|
||||
existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash]
|
||||
|
||||
let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased]
|
||||
if | existsChunk -> lift setContentBased
|
||||
| otherwise -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $
|
||||
@ -144,7 +150,22 @@ sinkFile File{ fileContent = Nothing, .. } = return FileReference
|
||||
, fileReferenceModified = fileModified
|
||||
}
|
||||
sinkFile File{ fileContent = Just fileContentContent, .. } = do
|
||||
(unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE
|
||||
chunk <- liftIO newEmptyTMVarIO
|
||||
sourceAsync <- allocateLinkedAsync . runConduit $ fileContentContent .| C.mapM_ (atomically . putTMVar chunk)
|
||||
|
||||
isEmpty <- atomically $
|
||||
False <$ readTMVar chunk
|
||||
<|> True <$ waitSTM sourceAsync
|
||||
|
||||
let fileContentContent' = evalContT . callCC $ \finishConsume -> forever $ do
|
||||
inpChunk <- atomically $
|
||||
Right <$> takeTMVar chunk
|
||||
<|> Left <$> waitCatchSTM sourceAsync
|
||||
|
||||
case inpChunk of
|
||||
Right inpChunk' -> lift $ yield inpChunk'
|
||||
Left (Left exc) -> throwM exc
|
||||
Left (Right res) -> finishConsume res
|
||||
|
||||
fileContentHash <- if
|
||||
| not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent'
|
||||
|
||||
Reference in New Issue
Block a user