fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(tutorial): towards #2347 exam occurrence form added (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2025-01-08 15:28:10 +01:00
parent 8b52f00fb0
commit d37d39301c
6 changed files with 60 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/misc/de-de-formal.msg
View File

@ -36,3 +36,4 @@ NoProblem: Keine Probleme gefunden
Unknown: ist unbekannt
UnknownOrNotAllowed: ist unbekannt oder hier nicht erlaubt
Ambiguous: ist uneindeutig
Action: Aktion

1
messages/uniworx/misc/en-eu.msg
View File

@ -36,3 +36,4 @@ NoProblem: No Probleme found
Unknown: is unknown
UnknownOrNotAllowed: is unknown or not allowed here
Ambiguous: is ambiguous
Action: Action

44
src/Handler/Exam/Form.hs
View File

@ -7,6 +7,7 @@ module Handler.Exam.Form
, ExamOccurrenceForm(..)
, ExamPartForm(..)
, examForm
, examOccurrenceMultiForm, examOccurrenceForm
, examFormTemplate, examTemplate
, validateExam
) where
@ -137,7 +138,7 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
<*> aopt utcTimeField (fslpI MsgExamPartsFrom (mr MsgDate) & setTooltip MsgExamPartsFromTip) (efPartsFrom <$> template)
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
<* aformSection MsgExamFormOccurrences
<*> examOccurrenceForm (efOccurrences <$> template)
<*> examOccurrenceMultiForm (efOccurrences <$> template)
<* aformSection MsgExamFormAutomaticFunctions
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
@ -250,24 +251,9 @@ examCorrectorsForm mPrev = wFormToAForm $ do
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgExamCorrectorsTip) False (Set.toList <$> mPrev)
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
where
examinerField = knownUserField True $ Just $ E.from $ \usr -> do
E.where_ $
(E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser E.==. usr E.^. UserId
) E.||.
(E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer E.==. E.just (usr E.^. UserId)
)
pure usr
examOccurrenceForm' nudge mPrev csrf = 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)
(eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions!
@ -280,7 +266,6 @@ examOccurrenceForm prev = wFormToAForm $ do
(eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev)
(eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev)
(eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)
return ( ExamOccurrenceForm
<$> eofIdRes
<*> eofNameRes
@ -293,16 +278,33 @@ examOccurrenceForm prev = wFormToAForm $ do
<*> eofDescRes
, $(widgetFile "widgets/massinput/examRooms/form")
)
where
examinerField = knownUserField True $ Just $ E.from $ \usr -> do
E.where_ $
(E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser E.==. usr E.^. UserId
) E.||.
(E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer E.==. E.just (usr E.^. UserId)
)
pure usr
examOccurrenceMultiForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceMultiForm prev = wFormToAForm $ do
currentRoute <- fromMaybe (error "examOccurrenceMultiForm called from 404-handler") <$> getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
where
miAdd' nudge submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
(res, formWidget) <- examOccurrenceForm nudge Nothing csrf
let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
| otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
miCell' nudge dat = examOccurrenceForm nudge (Just dat)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
miIdent' :: Text
miIdent' = "exam-occurrences"

30
src/Handler/Tutorial/Users.hs
View File

@ -16,6 +16,7 @@ import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Course.Cache
import Handler.Utils.Tutorial
import Handler.Exam.Form (examOccurrenceMultiForm, ExamOccurrenceForm(..))
import Database.Persist.Sql (deleteWhereCount)
import qualified Data.CaseInsensitive as CI
@ -44,22 +45,28 @@ embedRenderMessage ''UniWorX ''GenTutAction id
data GenTutActionData
= GenTutActNoneData -- Dummy action to hide form in a more natural way
| GenTutActOccAddData
{ -- gtaoaExam :: ExamId,
gtaoaOcc :: Set ExamOccurrenceForm
}
| GenTutActOccEditData
deriving (Eq, Ord, Read, Show, Generic)
deriving (Eq, Ord, Show, Generic)
genTutActionMap ::(_ -> Text) -> Map GenTutAction (AForm Handler GenTutActionData)
genTutActionMap _mr = Map.fromList
[ (GenTutActNone
, pure GenTutActNoneData )
, (GenTutActOccAdd
, pure GenTutActOccAddData )
, (GenTutActOccAdd, GenTutActOccAddData
<$> examOccurrenceMultiForm Nothing -- TODO
)
, (GenTutActOccEdit
, pure GenTutActOccEditData) -- TODO
]
makeGenTutActionForm :: (_ -> Text) -> Form GenTutActionData
makeGenTutActionForm mr html = flip (renderAForm FormStandard) html $ multiActionA (genTutActionMap mr) (fslI MsgGenTutActions) (Just GenTutActNone)
makeGenTutActionForm mr html = flip (renderAForm FormStandard) html $ multiActionA (genTutActionMap mr) (fslI MsgAction) (Just GenTutActNone)
-- TODO: Idee: MultiAction für jedes Exam, um so die einzelnen Occurrences zu markieren!
-- Default muss auch entsprechend generiert werden, wenn keine Occurrences für den Tag existieren
-- Im Form sollten die neuen markiert werden als ungespeichert! Generell wünschenswert für MassInput!
data TutorialUserAction
= TutorialUserAssignExam
@ -166,7 +173,7 @@ postTUsersR tid ssh csh tutn = do
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
let mbAletter = anyone letters
case mbAletter of
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
Just aletter -> do
apcIdent <- letterApcIdent aletter encRcvr now
let fName = letterFileName aletter
@ -220,8 +227,8 @@ postTUsersR tid ssh csh tutn = do
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
case tcontent of
Just act -> act -- abort and return produced content
Nothing -> do
Just act -> act -- execute action and return produced content
Nothing -> do -- no table action, continue normally
tutors <- runDB $ E.select $ do
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
`E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
@ -230,7 +237,7 @@ postTUsersR tid ssh csh tutn = do
let mr :: (() -> Text) = const "TODO: message renderer for general tutorial action form" -- getMessageRender
genTutActWgt <- do
((_gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ makeGenTutActionForm mr
((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ makeGenTutActionForm mr
let gtaAnchor = "general-tutorial-action-form" :: Text
gtaRoute = croute :#: gtaAnchor
gtaForm = wrapForm gtaWgt FormSettings
@ -241,6 +248,11 @@ postTUsersR tid ssh csh tutn = do
, formSubmit = FormSubmit
, formAnchor = Just gtaAnchor
}
formResult gtaRes $ \case
GenTutActNoneData -> return ()
GenTutActOccAddData{} -> error "not yet implemended" -- TODO
GenTutActOccEditData{} -> error "not yet implemended" -- TODO
-----------------------------------------------
-- !!!!!TODO: evaluate form result !!!!!!!!! --

8
src/Handler/Utils/Form/MassInput.hs
View File

@ -323,12 +323,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
runTwice act = do
r <- ask
s <- State.get
res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s
res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s
local (_1 .~ Nothing) . act $ Just res1
replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
replaceWithFirst Nothing xs = xs
replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
(shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
let sentLiveliness' = maybe sentLiveliness (view _2) mPrev
@ -567,7 +567,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
where
prevElems = Map.elems prevData
startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
startKey = maybe 0 (succ . fst) $ Map.lookupMax prevData
miCell :: ListPosition -> cellData -> Maybe () -> (Text -> Text)
-> (Markup -> MForm handler (FormResult (), Widget))
@ -643,7 +643,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
where
prevElems = Map.elems prevData
startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
startKey = maybe 0 (succ . fst) $ Map.lookupMax prevData
miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text)
-> (Markup -> MForm handler (FormResult cellData, Widget))

18
src/Utils/Set.hs
View File

@ -14,7 +14,7 @@ module Utils.Set
, mapIntersectNotOne
, set2NonEmpty
, maybeInsert
) where
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
@ -27,7 +27,7 @@ import Control.Lens
-- | cardinal number of an intersection of a set and a list of sets
setIntersectNotOne :: Ord a => Set a -> [Set a] -> Int
setIntersectNotOne :: Ord a => Set a -> [Set a] -> Int
setIntersectNotOne _ [] = 0
setIntersectNotOne k r = Set.size $ Set.intersection k others where others = Set.unions r
@ -37,14 +37,14 @@ setIntersectNotOne k r = Set.size $ Set.intersection k others where others = Set
-- | extracts from a map a list of values (sets) without one specific entry (a)
getAllElemsWithoutOne :: (Ord a) => Map a (Set b) -> a -> [Set b]
getAllElemsWithoutOne m cid = Map.elems $ Map.delete cid m
getAllElemsWithoutOne m cid = Map.elems $ Map.delete cid m
-- | transforms values (sets) of a map to integers. The number gives information about how many entreis are not only in this one
mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int
mapIntersectNotOne m = Map.mapWithKey f m where
-- | transforms values (sets) of a map to integers. The number gives information about how many entreis are not only in this one
mapIntersectNotOne :: forall a b. (Ord a, Ord b) => Map a (Set b) -> Map a Int
mapIntersectNotOne m = Map.mapWithKey f m where
f :: a -> Set b -> Int
f k _ = setIntersectNotOne (Map.findWithDefault Set.empty k m) (getAllElemsWithoutOne m k)
--------------------------
-- Functions from Utils --
--------------------------
@ -56,6 +56,7 @@ setIntersections (h:t) = foldl' Set.intersection h t
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
-- setMapMaybe f = Set.foldr (maybeInsert . f) Set.empty -- actually half as efficient as previous line using -O2
-- | like `setMapMaybe`, but only when f is strictly increasing
setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b
@ -75,7 +76,7 @@ setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList
-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
--
--
setPartitionEithers :: Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right)
@ -88,5 +89,6 @@ set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t
set2NonEmpty d _ = d NonEmpty.:| []
maybeInsert :: Ord a => Maybe a -> Set a -> Set a
-- maybeInsert = flip (ap maybe (flip Set.insert))
maybeInsert Nothing = id
maybeInsert (Just k) = Set.insert k