chore(tutorial): towards #2347 exam occurrence form mostly working (WIP)
form is completed, but the initial call needs proper arguments from DB about all apropriate exams
This commit is contained in:
parent
4241c75afe
commit
9af4a3a22e
@ -64,6 +64,3 @@ CheckEyePermitMissing: Sehtest oder Führerschein fehlen noch
|
||||
CheckEyePermitIncompatible: Sehtest und Führerschein passen nicht zusammen
|
||||
|
||||
GenTutActions: Prüfungsaktionen
|
||||
GenTutActNone !ident-ok: --
|
||||
GenTutActOccAdd: Neuen Prüfungstermin hinzufügen
|
||||
GenTutActOccEdit: Prüfungstermin bearbeiten
|
||||
@ -65,6 +65,3 @@ CheckEyePermitMissing: Eye exam or driving permit missing
|
||||
CheckEyePermitIncompatible: Eye exam and driving permit are incompatible
|
||||
|
||||
GenTutActions: Examination actions
|
||||
GenTutActNone: --
|
||||
GenTutActOccAdd: Add new exam occurence
|
||||
GenTutActOccEdit: Edit exam occurence
|
||||
@ -47,7 +47,7 @@ ExamOccurrence
|
||||
end UTCTime Maybe
|
||||
description StoredMarkup Maybe
|
||||
UniqueExamOccurrence exam name
|
||||
deriving Show Generic Binary
|
||||
deriving Eq Ord Show Generic Binary
|
||||
ExamRegistration
|
||||
exam ExamId
|
||||
user UserId
|
||||
|
||||
@ -75,35 +75,7 @@ postEEditR tid ssh csh examn = do
|
||||
|
||||
occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
|
||||
deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
|
||||
forM_ (Set.toList efOccurrences) $ \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
|
||||
}
|
||||
upsertExamOccurrences eId $ Set.toList efOccurrences
|
||||
|
||||
pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
|
||||
|
||||
|
||||
@ -8,6 +8,7 @@ module Handler.Exam.Form
|
||||
, ExamPartForm(..)
|
||||
, examForm
|
||||
, examOccurrenceMultiForm, examOccurrenceForm
|
||||
, upsertExamOccurrences
|
||||
, examFormTemplate, examTemplate
|
||||
, validateExam
|
||||
) where
|
||||
@ -309,6 +310,40 @@ 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)
|
||||
=> 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
|
||||
}
|
||||
|
||||
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
|
||||
examPartsForm prev = wFormToAForm $ do
|
||||
currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
@ -3,12 +3,15 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
|
||||
module Handler.Tutorial.Users
|
||||
( getTUsersR, postTUsersR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Control.Monad.Zip (munzip)
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Print
|
||||
@ -16,11 +19,12 @@ import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Course.Cache
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Exam.Form (examOccurrenceMultiForm, ExamOccurrenceForm(..))
|
||||
import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences)
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
@ -32,42 +36,39 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications
|
||||
import Handler.Course.Users
|
||||
|
||||
|
||||
data GenTutAction
|
||||
= GenTutActNone -- Dummy action to hide form in a more natural way
|
||||
| GenTutActOccAdd
|
||||
| GenTutActOccEdit
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
|
||||
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, Show, Generic)
|
||||
|
||||
genTutActionMap ::(_ -> Text) -> Map GenTutAction (AForm Handler GenTutActionData)
|
||||
genTutActionMap _mr = Map.fromList
|
||||
[ (GenTutActNone
|
||||
, pure GenTutActNoneData )
|
||||
, (GenTutActOccAdd, GenTutActOccAddData
|
||||
<$> examOccurrenceMultiForm Nothing -- TODO
|
||||
)
|
||||
, (GenTutActOccEdit
|
||||
, pure GenTutActOccEditData) -- TODO
|
||||
]
|
||||
|
||||
makeGenTutActionForm :: (_ -> Text) -> Form GenTutActionData
|
||||
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!
|
||||
|
||||
instance PathPiece a => PathPiece [a] where
|
||||
toPathPiece = tshow . map toPathPiece
|
||||
fromPathPiece (Text.uncons -> Just ('[', Text.unsnoc -> Just (Text.split (==',') -> xs,']'))) =
|
||||
mapM fromPathPiece xs
|
||||
fromPathPiece _ = Nothing
|
||||
|
||||
-- instance PathPiece [Data.CryptoID.CryptoID "ExamOccurrence" UUID] where
|
||||
-- toPathPiece = tshow $ map toPathPiece
|
||||
-- fromPathPiece = error "TODO"
|
||||
|
||||
-- | Generate multiForm with one entry for each course exam showing only day-relevant exam occurrences
|
||||
mkExamOccurrenceForm :: [(ExamId, CryptoUUIDExam, ExamName)] -> ExamOccurrenceMap -> Form (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
||||
mkExamOccurrenceForm exs eom = renderAForm FormStandard maa
|
||||
where
|
||||
maa = multiActionA acts (fslI MsgCourseExam) Nothing
|
||||
eid2eos = convertExamOccurrenceMap eom
|
||||
|
||||
acts :: Map Text (AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
|
||||
acts = Map.fromList $ map mkAct exs
|
||||
|
||||
mkAct :: (ExamId, CryptoUUIDExam, ExamName) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
|
||||
mkAct (eId, cueId, eName) = (ciOriginal eName,
|
||||
let (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
|
||||
in (,,)
|
||||
<$> areq hiddenField "teoExam" (Just cueId)
|
||||
<*> areq (mkSetField hiddenField) "teoOccs" cuEoIds
|
||||
<*> examOccurrenceMultiForm eos
|
||||
)
|
||||
|
||||
data TutorialUserAction
|
||||
= TutorialUserAssignExam
|
||||
| TutorialUserPrintQualification
|
||||
@ -136,7 +137,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
qualOptions = qualificationsOptionList qualifications
|
||||
lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
|
||||
timespan = lessonTimesSpan lessons
|
||||
exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid -- TODO: change back default to True
|
||||
exOccs <- flip foldMapM timespan $ getDayExamOccurrences True ssh $ Just cid
|
||||
let
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList $
|
||||
@ -208,7 +209,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
reloadKeepGetParams croute
|
||||
(TutorialUserAssignExamData{..}, selectedUsers)
|
||||
| (Just (ExamOccurrence{..}, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
|
||||
| (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
|
||||
let n = Set.size selectedUsers
|
||||
capOk <- ifNothing examOccurrenceCapacity (pure True) $ \(fromIntegral -> totalCap) -> do
|
||||
usedCap <- runDBRead $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. Set.toList selectedUsers]
|
||||
@ -235,9 +236,8 @@ postTUsersR tid ssh csh tutn = do
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
|
||||
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 $ mkExamOccurrenceForm [] exOccs -- TODO
|
||||
let gtaAnchor = "general-tutorial-action-form" :: Text
|
||||
gtaRoute = croute :#: gtaAnchor
|
||||
gtaForm = wrapForm gtaWgt FormSettings
|
||||
@ -248,15 +248,13 @@ 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 !!!!!!!!! --
|
||||
-----------------------------------------------
|
||||
formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
||||
let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs
|
||||
eId <- decrypt cEId
|
||||
eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
|
||||
runDB $ do
|
||||
deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
|
||||
upsertExamOccurrences eId $ Set.toList occs
|
||||
|
||||
return [whamlet|
|
||||
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
||||
|
||||
@ -8,6 +8,7 @@ import Import
|
||||
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Occurrences
|
||||
import Handler.Exam.Form (ExamOccurrenceForm(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -131,7 +132,8 @@ getDayTutorials ssh dlimit@(dstart, dend )
|
||||
-- mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
|
||||
-- mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
|
||||
|
||||
type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, (ExamId, ExamName))
|
||||
type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))
|
||||
type ExamToOccurrencesMap = Map ExamId (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
||||
|
||||
-- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching
|
||||
-- if a CourseId is specified, only exams from that course are returned
|
||||
@ -152,17 +154,34 @@ getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend)
|
||||
, Just $ E.withinPeriod dlimit (occ E.^. ExamOccurrenceStart) (occ E.^. ExamOccurrenceEnd)
|
||||
]
|
||||
return (occ, exm E.^. ExamId, exm E.^. ExamName) -- No Binary instance for Entity Exam, so we only extract what is needed for now
|
||||
return $ foldMap mkOccMap candidates
|
||||
foldMapM mkOccMap candidates
|
||||
where
|
||||
mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> ExamOccurrenceMap
|
||||
mkOccMap (Entity{..}, E.Value eId, E.Value eName) = Map.singleton entityKey (entityVal, (eId, eName))
|
||||
mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap
|
||||
mkOccMap (Entity{..}, E.Value eId, E.Value eName) = encrypt entityKey <&> (\ceoId -> Map.singleton entityKey (entityVal, ceoId, (eId, eName)))
|
||||
|
||||
mkExamOccurrenceOptions :: ExamOccurrenceMap -> OptionList ExamOccurrenceId
|
||||
mkExamOccurrenceOptions = mkOptionListGrouped . groupSort . map mkEOOption . Map.toList
|
||||
where
|
||||
mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
|
||||
mkEOOption (eid, (ExamOccurrence{..}, (_,eName))) = (ciOriginal eName, [Option{..}])
|
||||
mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
|
||||
mkEOOption (eid, (ExamOccurrence{examOccurrenceName}, ceoId, (_,eName))) = (ciOriginal eName, [Option{..}])
|
||||
where
|
||||
optionDisplay = ciOriginal examOccurrenceName
|
||||
optionExternalValue = toPathPiece $ eName <> ":" <> examOccurrenceName
|
||||
optionExternalValue = toPathPiece ceoId
|
||||
optionInternalValue = eid
|
||||
|
||||
convertExamOccurrenceMap :: ExamOccurrenceMap -> ExamToOccurrencesMap
|
||||
convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom
|
||||
where
|
||||
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
|
||||
, eofExaminer = examOccurrenceExaminer
|
||||
, eofRoom = examOccurrenceRoom
|
||||
, eofRoomHidden = examOccurrenceRoomHidden
|
||||
, eofCapacity = examOccurrenceCapacity
|
||||
, eofStart = examOccurrenceStart
|
||||
, eofEnd = examOccurrenceEnd
|
||||
, eofDescription = examOccurrenceDescription
|
||||
}
|
||||
))
|
||||
@ -116,6 +116,10 @@ commentField msg = Field {..}
|
||||
fieldView _ _ _ _ _ = msg2widget msg
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
-- | Fields of sets are only allowed indirectly
|
||||
mkSetField :: (Ord a, Functor m) => Field m [a] -> Field m (Set a)
|
||||
mkSetField = convertField Set.fromList Set.toList
|
||||
|
||||
--------------------
|
||||
-- Field Settings --
|
||||
--------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user